DPMJET/pythia6115dpm3.f

   1 C*********************************************************************
   2 C*********************************************************************
   3 C*                                                                  **
   4 C*                                                    March 1997    **
   5 C*                                                                  **
   6 C*           The Lund Monte Carlo for Hadronic Processes            **
   7 C*                                                                  **
   8 C*                        PYTHIA version 6.1                        **
   9 C*                                                                  **
  10 C*                        Torbjorn Sjostrand                        **
  11 C*                Department of Theoretical Physics 2               **
  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 parts by                           **
  18 C*                         Stephen Mrenna                           **
  19 C*                    Argonne National Laboratory                   **
  20 C*          9700 South Cass Avenue, Argonne, IL 60439, USA          **
  21 C*                   phone + 1 - 630 - 252 - 7615                   **
  22 C*                    E-mail mrenna@hep.anl.gov                     **
  23 C*                                                                  **
  24 C*         Several parts are written by Hans-Uno Bengtsson          **
  25 C*          PYSHOW is written together with Mats Bengtsson          **
  26 C*     advanced popcorn baryon production written by Patrik Eden    **
  27 C*     CTEQ 3 parton distributions are by the CTEQ collaboration    **
  28 C*      GRV 94 parton distributions are by Glueck, Reya and Vogt    **
  29 C*   SaS photon parton distributions together with Gerhard Schuler  **
  30 C*     g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt     **
  31 C*         MSSM Higgs mass calculation code by M. Carena,           **
  32 C*           J.R. Espinosa, M. Quiros and C.E.M. Wagner             **
  33 C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **
  34 C*                                                                  **
  35 C*   The latest program version and documentation is found on WWW   **
  36 C*       http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html       **
  37 C*                                                                  **
  38 C*              Copyright Torbjorn Sjostrand, Lund 1997             **
  39 C*                                                                  **
  40 C*********************************************************************
  41 C*********************************************************************
  42 C                                                                    *
  43 C  List of subprograms in order of appearance, with main purpose     *
  44 C  (S = subroutine, F = function, B = block data)                    *
  45 C                                                                    *
  46 C  B   PYDATA   to contain all default values                        *
  47 C  S   PYTEST   to test the proper functioning of the package        *
  48 C  S   PYHEPC   to convert between /PYJETS/ and /HEPEVT/ records     *
  49 C                                                                    *
  50 C  S   PYINIT   to administer the initialization procedure           *
  51 C  S   PYEVNT   to administer the generation of an event             *
  52 C  S   PYSTAT   to print cross-section and other information         *
  53 C  S   PYINRE   to initialize treatment of resonances                *
  54 C  S   PYINBM   to read in beam, target and frame choices            *
  55 C  S   PYINKI   to initialize kinematics of incoming particles       *
  56 C  S   PYINPR   to set up the selection of included processes        *
  57 C  S   PYXTOT   to give total, elastic and diffractive cross-sect.   *
  58 C  S   PYMAXI   to find differential cross-section maxima            *
  59 C  S   PYPILE   to select multiplicity of pileup events              *
  60 C  S   PYSAVE   to save alternatives for gamma-p and gamma-gamma     *
  61 C  S   PYRAND   to select subprocess and kinematics for event        *
  62 C  S   PYSCAT   to set up kinematics and colour flow of event        *
  63 C  S   PYSSPA   to simulate initial state spacelike showers          *
  64 C  S   PYRESD   to perform resonance decays                          *
  65 C  S   PYMULT   to generate multiple interactions                    *
  66 C  S   PYREMN   to add on target remnants                            *
  67 C  S   PYDIFF   to set up kinematics for diffractive events          *
  68 C  S   PYDOCU   to compute cross-sections and handle documentation   *
  69 C  S   PYFRAM   to perform boosts between different frames           *
  70 C  S   PYWIDT   to calculate full and partial widths of resonances   *
  71 C  S   PYOFSH   to calculate partial width into off-shell channels   *
  72 C  S   PYRECO   to handle colour reconnection in W+W- events         *
  73 C  S   PYKLIM   to calculate borders of allowed kinematical region   *
  74 C  S   PYKMAP   to construct value of kinematical variable           *
  75 C  S   PYSIGH   to calculate differential cross-sections             *
  76 C  S   PYPDFU   to evaluate parton distributions                     *
  77 C  S   PYPDFL   to evaluate parton distributions at low x and Q^2    *
  78 C  S   PYPDEL   to evaluate electron parton distributions            *
  79 C  S   PYPDGA   to evaluate photon parton distributions (generic)    *
  80 C  S   PYGGAM   to evaluate photon parton distributions (SaS sets)   *
  81 C  S   PYGVMD   to evaluate VMD part of photon parton distributions  *
  82 C  S   PYGANO   to evaluate anomalous part of photon pdf's           *
  83 C  S   PYGBEH   to evaluate Bethe-Heitler part of photon pdf's       *
  84 C  S   PYGDIR   to evaluate direct contribution to photon pdf's      *
  85 C  S   PYPDPI   to evaluate pion parton distributions                *
  86 C  S   PYPDPR   to evaluate proton parton distributions              *
  87 C  F   PYCTEQ   to evaluate the CTEQ 3 proton parton distributions   *
  88 C  S   PYGRVL   to evaluate the GRV 94L pronton parton distributions *
  89 C  S   PYGRVM   to evaluate the GRV 94M pronton parton distributions *
  90 C  S   PYGRVD   to evaluate the GRV 94D pronton parton distributions *
  91 C  F   PYGRVV   auxiliary to the PYGRV* routines                     *
  92 C  F   PYGRVW   auxiliary to the PYGRV* routines                     *
  93 C  F   PYGRVS   auxiliary to the PYGRV* routines                     *
  94 C  F   PYHFTH   to evaluate threshold factor for heavy flavour       *
  95 C  S   PYSPLI   to find flavours left in hadron when one removed     *
  96 C  F   PYGAMM   to evaluate ordinary Gamma function Gamma(x)         *
  97 C  S   PYWAUX   to evaluate auxiliary functions W1(s) and W2(s)      *
  98 C  S   PYI3AU   to evaluate auxiliary function I3(s,t,u,v)           *
  99 C  F   PYSPEN   to evaluate Spence (dilogarithm) function Sp(x)      *
 100 C  S   PYQQBH   to evaluate matrix element for g + g -> Q + Qbar + H *
 101 C                                                                    *
 102 C  S   PYMSIN   to initialize the supersymmetry simulation           *
 103 C  S   PYAPPS   to determine MSSM parameters from SUGRA input        *
 104 C  F   PYRNMQ   to determine running quark masses                    *
 105 C  F   PYRNMT   to determine running top mass                        *
 106 C  S   PYTHRG   to calculate sfermion third-gen. mass eigenstates    *
 107 C  S   PYINOM   to calculate neutralino/chargino mass eigenstates    *
 108 C  F   PYRNM3   to determine running M3, gluino mass                 *
 109 C  S   PYEIG4   to calculate eigenvalues and -vectors in 4*4 matrix  *
 110 C  S   PYHGGM   to determine Higgs mass spectrum                     *
 111 C  S   PYSUBH   to determine Higgs masses in the MSSM                *
 112 C  S   PYPOLE   to determine Higgs masses in the MSSM                *
 113 C  S   PYVACU   to determine Higgs masses in the MSSM                *
 114 C  S   PYRGHM   auxiliary to PYVACU                                  *
 115 C  S   PYGFXX   auxiliary to PYRGHM                                  *
 116 C  F   PYFINT   auxiliary to PYVACU                                  *
 117 C  F   PYFISB   auxiliary to PYFINT                                  *
 118 C  S   PYSFDC   to calculate sfermion decay partial widths           *
 119 C  S   PYGLUI   to calculate gluino decay partial widths             *
 120 C  S   PYTBBN   to calculate 3-body decay of gluino to neutralino    *
 121 C  S   PYTBBC   to calculate 3-body decay of gluino to chargino      *
 122 C  S   PYNJDC   to calculate neutralino decay partial widths         *
 123 C  S   PYCJDC   to calculate chargino decay partial widths           *
 124 C  F   PYXXZ5   auxiliary for neutralino 3-body decay                *
 125 C  F   PYXXW5   auxiliary for ino charge change 3-body decay         *
 126 C  F   PYXXGA   auxiliary for ino -> ino + gamma decay               *
 127 C  F   PYX2XG   auxiliary for ino -> ino + gauge boson decay         *
 128 C  F   PYX2XH   auxiliary for ino -> ino + Higgs decay               *
 129 C  F   PYXXZ2   auxiliary for chargino 3-body decay                  *
 130 C  S   PYHEXT   to calculate non-SM Higgs decay partial widths       *
 131 C  F   PYH2XX   auxiliary for H -> ino + ino decay                   *
 132 C  F   PYGAUS   to perform Gaussian integration                      *
 133 C  F   PYSIMP   to perform Simpson integration                       *
 134 C  F   PYLAMF   to evaluate the lambda kinematics function           *
 135 C  S   PYTBDY   to perform 3-body decay of gauginos                  *
 136 C                                                                    *
 137 C  S   PY1ENT   to fill one entry (= parton or particle)             *
 138 C  S   PY2ENT   to fill two entries                                  *
 139 C  S   PY3ENT   to fill three entries                                *
 140 C  S   PY4ENT   to fill four entries                                 *
 141 C  S   PYJOIN   to connect entries with colour flow information      *
 142 C  S   PYGIVE   to fill (or query) commonblock variables             *
 143 C  S   PYEXEC   to administrate fragmentation and decay chain        *
 144 C  S   PYPREP   to rearrange showered partons along strings          *
 145 C  S   PYSTRF   to do string fragmentation of jet system             *
 146 C  S   PYINDF   to do independent fragmentation of one or many jets  *
 147 C  S   PYDECY   to do the decay of a particle                        *
 148 C  S   PYDCYK   to select parton and hadron flavours in decays       *
 149 C  S   PYKFDI   to select parton and hadron flavours in fragm        *
 150 C  S   PYNMES   to select number of popcorn mesons                   *
 151 C  S   PYKFIN   to calculate falvour prod. ratios from input params. *
 152 C  S   PYPTDI   to select transverse momenta in fragm                *
 153 C  S   PYZDIS   to select longitudinal scaling variable in fragm     *
 154 C  S   PYSHOW   to do timelike parton shower evolution               *
 155 C  S   PYBOEI   to include Bose-Einstein effects (crudely)           *
 156 C  F   PYMASS   to give the mass of a particle or parton             *
 157 C  S   PYNAME   to give the name of a particle or parton             *
 158 C  F   PYCHGE   to give three times the electric charge              *
 159 C  F   PYCOMP   to compress standard KF flavour code to internal KC  *
 160 C  S   PYERRM   to write error messages and abort faulty run         *
 161 C  F   PYALEM   to give the alpha_electromagnetic value              *
 162 C  F   PYALPS   to give the alpha_strong value                       *
 163 C  F   PYANGL   to give the angle from known x and y components      *
 164 C  F   PYR      to provide a random number generator                 *
 165 C  S   PYRGET   to save the state of the random number generator     *
 166 C  S   PYRSET   to set the state of the random number generator      *
 167 C  S   PYROBO   to rotate and/or boost an event                      *
 168 C  S   PYEDIT   to remove unwanted entries from record               *
 169 C  S   PYLIST   to list event record or particle data                *
 170 C  S   PYLOGO   to write a logo                                      *
 171 C  S   PYUPDA   to update particle data                              *
 172 C  F   PYK      to provide integer-valued event information          *
 173 C  F   PYP      to provide real-valued event information             *
 174 C  S   PYSPHE   to perform sphericity analysis                       *
 175 C  S   PYTHRU   to perform thrust analysis                           *
 176 C  S   PYCLUS   to perform three-dimensional cluster analysis        *
 177 C  S   PYCELL   to perform cluster analysis in (eta, phi, E_T)       *
 178 C  S   PYJMAS   to give high and low jet mass of event               *
 179 C  S   PYFOWO   to give Fox-Wolfram moments                          *
 180 C  S   PYTABU   to analyze events, with tabular output               *
 181 C                                                                    *
 182 C  S   PYEEVT   to administrate the generation of an e+e- event      *
 183 C  S   PYXTEE   to give the total cross-section at given CM energy   *
 184 C  S   PYRADK   to generate initial state photon radiation           *
 185 C  S   PYXKFL   to select flavour of primary qqbar pair              *
 186 C  S   PYXJET   to select (matrix element) jet multiplicity          *
 187 C  S   PYX3JT   to select kinematics of three-jet event              *
 188 C  S   PYX4JT   to select kinematics of four-jet event               *
 189 C  S   PYXDIF   to select angular orientation of event               *
 190 C  S   PYONIA   to perform generation of onium decay to gluons       *
 191 C                                                                    *
 192 C  S   PYBOOK   to book a histogram                                  *
 193 C  S   PYFILL   to fill an entry in a histogram                      *
 194 C  S   PYFACT   to multiply histogram contents by a factor           *
 195 C  S   PYOPER   to perform operations between histograms             *
 196 C  S   PYHIST   to print and reset all histograms                    *
 197 C  S   PYPLOT   to print a single histogram                          *
 198 C  S   PYNULL   to reset contents of a single histogram              *
 199 C  S   PYDUMP   to dump histogram contents onto a file               *
 200 C                                                                    *
 201 C  S   PYKCUT   dummy routine for user kinematical cuts              *
 202 C  S   PYEVWT   dummy routine for weighting events                   *
 203 C  S   PYUPIN   dummy routine to initialize a user process           *
 204 C  S   PYUPEV   dummy routine to generate a user process event       *
 205 C  S   PDFSET   dummy routine to be removed when using PDFLIB        *
 206 C  S   STRUCTM  dummy routine to be removed when using PDFLIB        *
 207 C  S   PYTAUD   dummy routine for interface to tau decay libraries   *
 208 C  S   PYTIME   dummy routine for giving date and time               *
 209 C                                                                    *
 210 C*********************************************************************
 211
 212 *$ CREATE PYDATA.FOR
 213 *COPY PYDATA
 214 C...PYDATA
 215 C...Default values for switches and parameters,
 216 C...and particle, decay and process data.
 217
 218       BLOCK DATA PYDATA
 219
 220 C...Double precision and integer declarations.
 221       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
 222       INTEGER PYK,PYCHGE,PYCOMP
 223 C...Commonblocks.
 224       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 225       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 226       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
 227       COMMON/PYDAT4/CHAF(500,2)
 228       CHARACTER CHAF*16
 229       COMMON/PYDATR/MRPY(6),RRPY(100)
 230       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
 231       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
 232       COMMON/PYINT1/MINT(400),VINT(400)
 233       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
 234       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
 235       COMMON/PYINT4/MWID(500),WIDS(500,5)
 236       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
 237       COMMON/PYINT6/PROC(0:500)
 238       CHARACTER PROC*28
 239       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
 240       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
 241       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
 242      &SFMIX(16,4)
 243       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
 244       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
 245      &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
 246      &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYBINS/
 247
 248 C...PYDAT1, containing status codes and most parameters.
 249       DATA MSTU/
 250      &   0,    0,    0, 4000,10000,  500, 4000,    0,    0,    2,
 251      1   6,    1,    1,    0,    1,    1,    0,    0,    0,    0,
 252      2   2,   10,    0,    0,    1,   10,    0,    0,    0,    0,
 253      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 254      4   2,    2,    1,    4,    2,    1,    1,    0,    0,    0,
 255      5  25,   24,    0,    1,    0,    0,    0,    0,    0,    0,
 256      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 257      7  30*0,
 258      1   1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 259      2   1,    5,    3,    5,    0,    0,    0,    0,    0,    0,
 260      &  80*0/
 261       DATA PARU/
 262      &  3.141592653589793D0, 6.283185307179586D0,
 263      &  0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0,  4*0D0,
 264      1  0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
 265      2  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
 266      3  0D0,   0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,
 267      4  2.0D0,  1.0D0, 0.25D0,  2.5D0, 0.05D0,
 268      4  0D0,   0D0, 0.0001D0, 0D0,   0D0,
 269      5  2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
 270      6  40*0D0,
 271      &  0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
 272      &  0D0, 0D0, 0D0, 0D0,  0D0,
 273      1  0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0,  0D0, 0D0, 0D0,
 274      2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
 275      2 -1.0D0,  1.0D0,  1.0D0,  1.0D0,  0D0,
 276      3  1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 277      4  5.0D0, 1.0D0, 1.0D0,  0D0, 1.0D0, 1.0D0,  0D0, 0D0, 0D0, 0D0,
 278      5  1.0D0, 0D0, 0D0, 0D0, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,0D0,
 279      6  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 280      7  1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
 281      8  1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
 282      9  0D0,  0D0,  0D0,  0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0/
 283       DATA MSTJ/
 284      &  1,    3,    0,    0,    0,    0,    0,    0,    0,    0,
 285      1  4,    2,    0,    1,    0,    0,    0,    0,    0,    0,
 286      2  2,    1,    1,    2,    1,    2,    2,    0,    0,    0,
 287      3  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
 288      4  2,    2,    4,    2,    5,    3,    3,    0,    0,    3,
 289      5  0,    3,    0,    0,    0,    0,    0,    0,    0,    0,
 290      6  40*0,
 291      &  5,    2,    7,    5,    1,    1,    0,    2,    0,    2,
 292      1  0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
 293      2  80*0/
 294       DATA PARJ/
 295      &  0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
 296      &  0.50D0, 0.50D0,   0.6D0,   1.2D0,   0.6D0,
 297      1  0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
 298      2  0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
 299      3  0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0,2.5D0,0.6D0,0D0,
 300      4  0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0,
 301      5  0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
 302      5 -0.00001D0, -0.00001D0, -0.00001D0, 1.0D0, 0D0,
 303      6  4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
 304      7  10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0, 0D0, 0D0,
 305      8  0.29D0, 1.0D0, 1.0D0,  0D0,  10D0, 10D0, 0D0, 0D0, 0D0, 0D0,
 306      9  0.02D0, 1.0D0, 0.2D0,  0D0,  0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
 307      &  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
 308      1  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
 309      2  1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
 310      2  2.0D0,  1.0D0, 0.25D0,0.002D0,   0D0,
 311      3  0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0,  0.2D0,   0D0,
 312      4  60*0D0/
 313
 314 C...PYDAT2, with particle data and flavour treatment parameters.
 315       DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
 316      &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,
 317      &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*3,
 318      &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,
 319      &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,
 320      &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,
 321      &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,
 322      &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,
 323      &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/
 324       DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,
 325      &3*0,-1,4*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
 326      &-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,
 327      &6*1,6*0,2*1,165*0/
 328       DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1,
 329      &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0,
 330      &102*1,2*0,2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,
 331      &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/
 332       DATA (KCHG(I,4),I=   1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
 333      &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
 334      &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
 335      &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
 336      &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
 337      &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,
 338      &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,
 339      &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,
 340      &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,
 341      &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,
 342      &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,
 343      &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,
 344      &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,
 345      &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,
 346      &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,
 347      &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,
 348      &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,
 349      &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,
 350      &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,
 351      &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/
 352       DATA (KCHG(I,4),I= 294, 500)/20443,20513,20523,20533,20543,20553,
 353      &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,
 354      &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,
 355      &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,
 356      &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,
 357      &2000015,2000016,4000001,4000002,4000011,4000012,163*0/
 358       DATA (PMAS(I,1),I=   1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0,
 359      &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,
 360      &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0,
 361      &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0,
 362      &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0,
 363      &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0,
 364      &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0,
 365      &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0,
 366      &1.9685D0,2.1124D0,2.5735D0,0D0,2.9798D0,3.09688D0,3.5562D0,
 367      &5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,5.3693D0,
 368      &5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,9.9132D0,
 369      &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0,
 370      &0.77133D0,0D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
 371      &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
 372      &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
 373      &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
 374      &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
 375      &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
 376      &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
 377      &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0/
 378       DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0,
 379      &5.40145D0,5.8D0,5.81D0,5.8D0,5.81D0,5.84D0,7.00575D0,5.56725D0,
 380      &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
 381      &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
 382      &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
 383      &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
 384      &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
 385      &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
 386      &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
 387      &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
 388      &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
 389      &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
 390      &4*400D0,163*0D0/
 391       DATA (PMAS(I,2),I=   1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0,
 392      &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0,
 393      &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0,
 394      &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0,
 395      &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0,
 396      &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0,
 397      &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,
 398      &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*0D0,2*0.12D0,3*0D0,
 399      &0.0394D0,4*0D0,0.036D0,0D0,0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,
 400      &74*0D0,0.06D0,0.142D0,0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,
 401      &0.287D0,0.09D0,0.25D0,0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,
 402      &0D0,0.014D0,0.01D0,8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,
 403      &0.053D0,3*0.05D0,0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,
 404      &1D0,0D0,1D0,0D0,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/
 405       DATA (PMAS(I,3),I=   1, 500)/5*0D0,14D0,16*0D0,24.78326D0,
 406      &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0,
 407      &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0,
 408      &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0,
 409      &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
 410      &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,
 411      &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0,
 412      &3*0D0,2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,
 413      &0.05D0,0D0,0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,
 414      &0.4D0,0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,
 415      &0.08D0,0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,
 416      &2*0.3D0,0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,
 417      &3*0D0,19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,
 418      &0.00001D0,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*0D0/
 419       DATA (PMAS(I,4),I=   1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
 420      &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,0D0,7804.5D0,6*0D0,
 421      &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
 422      &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*0D0,
 423      &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
 424      &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
 425      &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
 426      &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,83*0D0,163*0D0/
 427       DATA PARF/
 428      &  0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0,  0D0,  0D0,  0D0, 0D0,
 429      1  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 430      2  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 431      3  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 432      4  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 433      5  0.5D0,  0D0, 0.5D0,  0D0,  1D0,  1D0,  0D0,  0D0,  0D0, 0D0,
 434      6  0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
 435      7  0D0,  0D0,  1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
 436      8  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 437      9  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 438      & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 439      1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
 440      2 0.2D0, 0.1D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
 441      3 60*0D0,
 442      4 0.2D0,  0.5D0,  8*0D0,
 443      5 1800*0D0/
 444       DATA ((VCKM(I,J),J=1,4),I=1,4)/
 445      &  0.95113D0,  0.04884D0,  0.00003D0,  0.00000D0,
 446      &  0.04884D0,  0.94940D0,  0.00176D0,  0.00000D0,
 447      &  0.00003D0,  0.00176D0,  0.99821D0,  0.00000D0,
 448      &  0.00000D0,  0.00000D0,  0.00000D0,  1.00000D0/
 449
 450 C...PYDAT3, with particle decay parameters and data.
 451       DATA (MDCY(I,1),I=   1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
 452      &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1,
 453      &0,18*1,0,1,4*0,1,3*0,2*1,2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,
 454      &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,
 455      &1,0,4*1,163*0/
 456       DATA (MDCY(I,2),I=   1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,
 457      &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,
 458      &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,
 459      &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,
 460      &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,
 461      &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,
 462      &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,
 463      &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,
 464      &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,
 465      &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,
 466      &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,
 467      &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,
 468      &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,
 469      &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,
 470      &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,
 471      &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,
 472      &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,
 473      &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,
 474      &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,
 475      &2493,2496,163*0/
 476       DATA (MDCY(I,3),I=   1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,
 477      &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18,
 478      &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6,
 479      &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0,
 480      &1,4*0,3,3*0,3,1,2*0,2,3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,
 481      &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,
 482      &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,
 483      &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,
 484      &15,0,2*4,3,2,163*0/
 485       DATA (MDME(I,1),I=   1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
 486      &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,2*-1,
 487      &3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,2*-1,
 488      &6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,197*1,2*-1,2*1,-1,20*1,
 489      &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1,
 490      &2*-1,1892*1,1503*0/
 491       DATA (MDME(I,2),I=   1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,
 492      &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
 493      &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,
 494      &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0,
 495      &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*0,12,2*42,2*11,9*42,0,2,3,
 496      &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,
 497      &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,
 498      &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,
 499      &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,
 500      &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,
 501      &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
 502      &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,
 503      &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,
 504      &4*32,2*4,5*0,828*53,1515*0/
 505       DATA (BRAT(I)  ,I=   1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0,
 506      &33*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,0.003D0,
 507      &0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,0.0071D0,
 508      &0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,0.0034D0,0.08D0,
 509      &0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,0.0067D0,0.0005D0,
 510      &0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,0.00075D0,0.0001D0,
 511      &0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,0.0004D0,0.0001D0,
 512      &2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,0.00025D0,35*0D0,
 513      &0.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0,
 514      &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0,
 515      &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0,
 516      &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0,
 517      &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0,
 518      &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0,
 519      &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0,
 520      &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0,
 521      &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0,
 522      &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0,
 523      &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0,
 524      &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/
 525       DATA (BRAT(I)  ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0,
 526      &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0,
 527      &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0,
 528      &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0,
 529      &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0,
 530      &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,
 531      &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0,
 532      &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0,
 533      &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,
 534      &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,
 535      &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,
 536      &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,
 537      &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,
 538      &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,
 539      &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,
 540      &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,
 541      &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,
 542      &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,
 543      &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,
 544      &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/
 545       DATA (BRAT(I)  ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0,
 546      &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,
 547      &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,
 548      &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,
 549      &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,
 550      &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,
 551      &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,
 552      &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,
 553      &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,
 554      &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
 555      &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,
 556      &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,
 557      &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,
 558      &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,
 559      &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,
 560      &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,
 561      &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,
 562      &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,
 563      &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
 564      &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
 565       DATA (BRAT(I)  ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0,
 566      &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
 567      &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
 568      &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
 569      &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
 570      &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
 571      &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
 572      &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
 573      &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
 574      &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
 575      &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
 576      &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
 577      &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
 578      &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
 579      &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
 580      &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
 581      &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
 582      &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
 583      &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
 584      &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
 585       DATA (BRAT(I)  ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0,
 586      &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
 587      &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
 588      &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
 589      &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
 590      &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
 591      &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
 592      &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
 593      &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
 594      &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
 595      &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
 596      &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
 597      &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
 598      &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
 599      &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
 600      &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
 601      &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
 602      &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
 603      &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
 604      &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
 605       DATA (BRAT(I)  ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
 606      &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
 607      &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
 608      &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
 609      &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
 610      &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
 611      &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
 612      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
 613      &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
 614      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
 615      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 616      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 617      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 618      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 619      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 620      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 621      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 622      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 623      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
 624      &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
 625       DATA (BRAT(I)  ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 626      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 627      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 628      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 629      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 630      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 631      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 632      &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
 633      &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
 634      &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
 635      &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
 636      &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
 637      &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
 638      &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
 639      &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
 640      &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
 641      &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
 642      &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
 643      &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
 644      &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
 645       DATA (BRAT(I)  ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0,
 646      &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0,
 647      &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0,
 648      &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0,
 649      &1503*0D0/
 650       DATA (KFDP(I,1),I=   1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,
 651      &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
 652      &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,
 653      &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,
 654      &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,
 655      &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,
 656      &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,
 657      &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,
 658      &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
 659      &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,
 660      &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
 661      &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
 662      &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
 663      &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
 664      &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
 665      &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
 666      &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,
 667      &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,
 668      &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,
 669      &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/
 670       DATA (KFDP(I,1),I= 376, 606)/1000003,-1000003,1000004,2000004,
 671      &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,
 672      &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,
 673      &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,
 674      &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,
 675      &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,
 676      &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,
 677      &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,
 678      &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,
 679      &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,
 680      &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,
 681      &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,
 682      &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,
 683      &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,
 684      &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,
 685      &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,
 686      &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,
 687      &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3,
 688      &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7,
 689      &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/
 690       DATA (KFDP(I,1),I= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,
 691      &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,
 692      &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,
 693      &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,
 694      &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,
 695      &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,
 696      &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,
 697      &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,
 698      &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,
 699      &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,
 700      &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,
 701      &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,
 702      &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,
 703      &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,
 704      &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,
 705      &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,
 706      &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,
 707      &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,
 708      &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,
 709      &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/
 710       DATA (KFDP(I,1),I=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,
 711      &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,
 712      &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,
 713      &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,
 714      &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,
 715      &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,
 716      &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,
 717      &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,
 718      &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,
 719      &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,
 720      &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,
 721      &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,
 722      &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,
 723      &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,
 724      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,
 725      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,
 726      &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,
 727      &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
 728      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
 729      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/
 730       DATA (KFDP(I,1),I=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
 731      &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
 732      &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
 733      &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
 734      &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
 735      &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
 736      &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
 737      &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
 738      &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
 739      &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
 740      &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
 741      &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
 742      &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
 743      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
 744      &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,
 745      &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,
 746      &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
 747      &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,
 748      &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,
 749      &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/
 750       DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006,
 751      &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,
 752      &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
 753      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
 754      &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,
 755      &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,
 756      &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,
 757      &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,
 758      &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,
 759      &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,
 760      &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,
 761      &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,
 762      &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,
 763      &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,
 764      &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,
 765      &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,
 766      &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
 767      &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,
 768      &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
 769      &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/
 770       DATA (KFDP(I,1),I=1901,2095)/-1000037,1000037,-1000037,1000037,
 771      &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,
 772      &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
 773      &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
 774      &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
 775      &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
 776      &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
 777      &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
 778      &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
 779      &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,
 780      &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,
 781      &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,
 782      &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,
 783      &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,
 784      &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,
 785      &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
 786      &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
 787      &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
 788      &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,
 789      &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/
 790       DATA (KFDP(I,1),I=2096,2323)/2000003,-2000003,1000004,-1000004,
 791      &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
 792      &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
 793      &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
 794      &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
 795      &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,
 796      &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,
 797      &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
 798      &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
 799      &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
 800      &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,
 801      &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,
 802      &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,
 803      &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,
 804      &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,
 805      &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,
 806      &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,
 807      &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,
 808      &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
 809      &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/
 810       DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006,
 811      &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,
 812      &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
 813      &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,
 814      &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,
 815      &1000039,1000024,1000037,1000022,1000023,1000025,1000035,
 816      &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,
 817      &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
 818      &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,
 819      &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,
 820      &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,
 821      &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,
 822      &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,
 823      &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,
 824      &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
 825      &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,
 826      &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,
 827      &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,
 828      &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,
 829      &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/
 830       DATA (KFDP(I,2),I=   1, 337)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
 831      &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,4*1000006,3*7,
 832      &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,
 833      &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
 834      &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
 835      &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
 836      &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
 837      &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
 838      &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
 839      &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
 840      &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
 841      &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
 842      &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
 843      &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
 844      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
 845      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
 846      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
 847      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
 848      &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
 849      &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/
 850       DATA (KFDP(I,2),I= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,
 851      &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,
 852      &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,
 853      &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
 854      &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
 855      &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
 856      &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
 857      &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
 858      &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
 859      &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,
 860      &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,
 861      &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,
 862      &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
 863      &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
 864      &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
 865      &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
 866      &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
 867      &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
 868      &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
 869      &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/
 870       DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,
 871      &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,
 872      &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,
 873      &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
 874      &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,
 875      &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,
 876      &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,
 877      &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,
 878      &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,
 879      &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,
 880      &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,
 881      &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,
 882      &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,
 883      &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,
 884      &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,
 885      &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,
 886      &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,
 887      &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,
 888      &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,
 889      &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/
 890       DATA (KFDP(I,2),I= 941,1318)/2*-15,211,213,20213,211,213,20213,
 891      &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
 892      &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
 893      &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,
 894      &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,
 895      &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,
 896      &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,
 897      &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,
 898      &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,
 899      &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,
 900      &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,
 901      &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,
 902      &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,
 903      &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,
 904      &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,
 905      &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,
 906      &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,
 907      &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,
 908      &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,
 909      &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/
 910       DATA (KFDP(I,2),I=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,
 911      &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,
 912      &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,
 913      &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,
 914      &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,
 915      &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,
 916      &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,
 917      &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,
 918      &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,
 919      &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,
 920      &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,
 921      &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,
 922      &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,
 923      &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,
 924      &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,
 925      &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,
 926      &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,
 927      &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24,
 928      &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11,
 929      &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/
 930       DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,
 931      &4*16,2*24,2*37,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,
 932      &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,
 933      &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,
 934      &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,
 935      &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,
 936      &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
 937      &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
 938      &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,
 939      &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,
 940      &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,
 941      &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,
 942      &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,
 943      &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,
 944      &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,
 945      &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,
 946      &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,
 947      &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,
 948      &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,
 949      &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/
 950       DATA (KFDP(I,2),I=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,
 951      &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
 952      &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,
 953      &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,
 954      &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
 955      &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
 956      &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,
 957      &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25,
 958      &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6,
 959      &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,
 960      &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,
 961      &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/
 962       DATA (KFDP(I,3),I=   1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,
 963      &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
 964      &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
 965      &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
 966      &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
 967      &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
 968      &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
 969      &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
 970      &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
 971      &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
 972      &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
 973      &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
 974      &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
 975      &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
 976      &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
 977      &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
 978      &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
 979      &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
 980      &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
 981      &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
 982       DATA (KFDP(I,3),I=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,
 983      &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
 984      &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
 985      &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,
 986      &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,
 987      &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,
 988      &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,
 989      &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,
 990      &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,
 991      &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
 992      &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,
 993      &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,
 994      &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,
 995      &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,
 996      &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,
 997      &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
 998      &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,
 999      &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,
1000      &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,
1001      &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/
1002       DATA (KFDP(I,3),I=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,
1003      &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,
1004      &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,
1005      &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/
1006       DATA (KFDP(I,4),I=   1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,
1007      &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1008      &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1009      &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1010      &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1011      &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1012      &-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,
1013      &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1014      &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,
1015      &162*81,31*0,-211,111,2450*0/
1016       DATA (KFDP(I,5),I=   1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,
1017      &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1018      &3*111,-211,111,3127*0/
1019
1020 C...PYDAT4, with particle names (character strings).
1021       DATA (CHAF(I,1),I=   1, 190)/'d','u','s','c','b','t','b''','t''',
1022      &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1023      &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',
1024      &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',
1025      &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',
1026      &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',
1027      &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',
1028      &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',
1029      &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',
1030      &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',
1031      &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',
1032      &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',
1033      &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',
1034      &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',
1035      &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',
1036      &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',
1037      &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',
1038      &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',
1039      &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',
1040      &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/
1041       DATA (CHAF(I,1),I= 191, 317)/'Sigma*_c+','Sigma_c++',
1042      &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',
1043      &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',
1044      &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',
1045      &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',
1046      &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1047      &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1048      &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1049      &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1050      &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1051      &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1052      &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1053      &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1054      &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1055      &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1056      &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1057      &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1058      &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1059      &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1060      &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/
1061       DATA (CHAF(I,1),I= 318, 500)/'~chi_30','~chi_40','~chi_2+',
1062      &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',
1063      &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',
1064      &'nu*_e0',163*' '/
1065       DATA (CHAF(I,2),I=   1, 206)/'dbar','ubar','sbar','cbar','bbar',
1066      &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1067      &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1068      &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',
1069      &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',
1070      &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',
1071      &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',
1072      &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',
1073      &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',
1074      &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',
1075      &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',
1076      &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',
1077      &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',
1078      &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',
1079      &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',
1080      &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',
1081      &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',
1082      &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',
1083      &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1084      &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/
1085       DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',
1086      &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',
1087      &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',
1088      &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',
1089      &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',
1090      &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',
1091      &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',
1092      &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',
1093      &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',
1094      &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',
1095      &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1096      &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1097      &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1098      &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1099      &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1100      &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1101      &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1102      &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1103      &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1104      &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/
1105       DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',
1106      &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',
1107      &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/
1108
1109 C...PYDATR, with initial values for the random number generator.
1110       DATA MRPY/19780503,0,0,97,33,0/
1111
1112 C...Default values for allowed processes and kinematics constraints.
1113       DATA MSEL/1/
1114       DATA MSUB/500*0/
1115       DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1116      &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,
1117      &6*1,4*0,4*1,16*0/
1118       DATA CKIN/
1119      &  2.0D0, -1.0D0,  0.0D0, -1.0D0,  1.0D0,
1120      &  1.0D0,  -10D0,   10D0,  -10D0,   10D0,
1121      1  -10D0,   10D0,  -10D0,   10D0,  -10D0,
1122      1   10D0, -1.0D0,  1.0D0, -1.0D0,  1.0D0,
1123      2  0.0D0,  1.0D0,  0.0D0,  1.0D0, -1.0D0,
1124      2  1.0D0, -1.0D0,  1.0D0,    0D0,    0D0,
1125      3  2.0D0, -1.0D0,    0D0,    0D0,  0.0D0,
1126      3 -1.0D0,  0.0D0, -1.0D0,  4.0D0, -1.0D0,
1127      4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1128      4 -1.0D0, 12.0D0, -1.0D0,    0D0,    0D0,
1129      5  0.0D0, -1.0D0,  0.0D0, -1.0D0,  0.0D0,
1130      5 -1.0D0,    0D0,    0D0,    0D0,    0D0,
1131      6  140*0D0/
1132
1133 C...Default values for main switches and parameters. Reset information.
1134       DATA (MSTP(I),I=1,100)/
1135      &  3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
1136      1  1,    0,    1,    0,    5,    0,    0,    0,    0,    0,
1137      2  1,    0,    1,    0,    0,    0,    0,    0,    0,    1,
1138      3  1,    2,    0,    1,    0,    2,    1,    5,    2,    0,
1139      4  1,    1,    3,    7,    3,    1,    1,    0,    1,    0,
1140      5  4,    1,    3,    1,    5,    1,    1,    6,    1,    7,
1141      6  1,    3,    2,    2,    1,    1,    2,    0,    0,    0,
1142      7  1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1143      8  1,    1,  100,    0,    0,    0,    0,    0,    0,    0,
1144      9  1,    4,    1,    2,    0,    0,    0,    0,    0,    0/
1145       DATA (MSTP(I),I=101,200)/
1146      &  3,    1,    0,    0,    0,    0,    0,    0,    0,    0,
1147      1  1,    1,    1,    0,    0,    0,    0,    0,    0,    0,
1148      2  0,    1,    2,    1,    1,   50,    0,    0,   10,    0,
1149      3  0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
1150      4  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1151      5  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1152      6  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1153      7  0,    2,    0,    0,    0,    0,    0,    0,    0,    0,
1154      8  6,  115, 1998,   01,   27,    0,    0,    0,    0,    0,
1155      9  0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1156       DATA (PARP(I),I=1,100)/
1157      &  0.25D0,  10D0, 8*0D0,
1158      1  0D0,   0D0,  1.0D0, 0.01D0,  0.6D0,  1.0D0,  1.0D0, 3*0D0,
1159      2  10*0D0,
1160      3  1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
1161      4  0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
1162      5  1.0D0, 9*0D0,
1163      6  0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1164      7  4.0D0, 0.25D0, 8*0D0,
1165      8  1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0,
1166      9  0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/
1167       DATA (PARP(I),I=101,200)/
1168      &  0.5D0, 0.28D0,  1.0D0, 0.8D0, 6*0D0,
1169      1  2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1170      2  1.0D0,  0.4D0, 8*0D0,
1171      3  0.01D0, 9*0D0,
1172      4  0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0,
1173      5  0D0,   0D0,   0D0,   0D0, 6*0D0,
1174      6  2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0,
1175      7  0D0,   0D0,   0D0,  1.0D0, 6*0D0,
1176      8  20*0D0/
1177       DATA MSTI/200*0/
1178       DATA PARI/200*0D0/
1179       DATA MINT/400*0/
1180       DATA VINT/400*0D0/
1181
1182 C...Constants for the generation of the various processes.
1183       DATA (ISET(I),I=1,100)/
1184      &  1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,    2,
1185      1  2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1186      2 -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
1187      3  2,   -1,    2,    2,    2,    2,   -1,   -1,   -1,   -1,
1188      4 -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
1189      5 -1,   -1,    2,    2,   -1,   -1,   -1,    2,   -1,   -1,
1190      6 -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,    2,    2,
1191      7  4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,    2,
1192      8  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
1193      9  0,    0,    0,    0,    0,    9,   -2,   -2,   -2,   -2/
1194       DATA (ISET(I),I=101,200)/
1195      & -1,    1,    1,   -2,   -2,    2,    2,    2,   -2,    2,
1196      1  2,    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,
1197      2  5,    5,    5,    5,   -2,   -2,   -2,   -2,   -2,   -2,
1198      3 -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
1199      4  1,    1,    1,    1,    1,   -2,    1,    1,    1,   -2,
1200      5  1,    1,    1,   -2,   -2,    1,    1,    1,   -2,   -2,
1201      6  2,    2,    2,    2,    2,    2,    2,    2,   -2,   -2,
1202      7  2,    2,    5,    5,   -2,    2,    2,    5,    5,   -2,
1203      8  5,    5,   -2,   -2,   -2,    5,    5,   -2,   -2,   -2,
1204      9  1,    1,    1,    2,   -2,   -2,   -2,   -2,   -2,   -2/
1205       DATA (ISET(I),I=201,300)/
1206      &  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1207      1  2,    2,    2,    2,   -2,    2,    2,    2,    2,    2,
1208      2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1209      3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1210      4  2,    2,    2,    2,   -1,    2,    2,    2,    2,    2,
1211      5  2,    2,    2,    2,   -1,    2,   -1,    2,    2,   -2,
1212      6  2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,   -1,
1213      7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
1214      8 -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,
1215      9 -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/
1216       DATA (ISET(I),I=301,500)/200*-2/
1217       DATA ((KFPR(I,J),J=1,2),I=1,50)/
1218      &  23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
1219      &  24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
1220      1   0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
1221      1  21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
1222      2  22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
1223      2  24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
1224      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1225      3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1226      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
1227      4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
1228       DATA ((KFPR(I,J),J=1,2),I=51,100)/
1229      5   0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
1230      5   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1231      6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1232      6   0,    0,    0,    0,   21,   21,   24,   24,   23,   24,
1233      7  23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
1234      7  23,   23,   24,   24,   24,   25,   25,   25,    0,  211,
1235      8   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1236      8 443,   21,10441,   21,20443,   21,  445,   21,    0,    0,
1237      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1238      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1239       DATA ((KFPR(I,J),J=1,2),I=101,150)/
1240      &  23,    0,   25,    0,   25,    0,    0,    0,    0,    0,
1241      & 443,   22,  443,   21,  443,   22,    0,    0,   22,   25,
1242      1  21,   25,    0,   25,   21,   25,   22,   22,   21,   22,
1243      1  22,   23,   23,   23,   24,   24,    0,    0,    0,    0,
1244      2  25,    6,   25,    6,   25,    0,   25,    0,    0,    0,
1245      2   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1246      3  23,    5,    0,    0,    0,    0,    0,    0,    0,    0,
1247      3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
1248      4  32,    0,   34,    0,   37,    0,   40,    0,   39,    0,
1249      4   0,    0, 4000001, 0, 4000002, 0,   38,    0,    0,    0/
1250       DATA ((KFPR(I,J),J=1,2),I=151,200)/
1251      5  35,    0,   35,    0,   35,    0,    0,    0,    0,    0,
1252      5  36,    0,   36,    0,   36,    0,    0,    0,    0,    0,
1253      6   6,   37,   39,    0,   39,   39,   39,   39,   11,    0,
1254      6  11,    0, 0, 4000001, 0, 4000002,    0,    0,    0,    0,
1255      7  23,   35,   24,   35,   35,    0,   35,    0,    0,    0,
1256      7  23,   36,   24,   36,   36,    0,   36,    0,    0,    0,
1257      8  35,    6,   35,    6,    0,    0,    0,    0,    0,    0,
1258      8  36,    6,   36,    6,    0,    0,    0,    0,    0,    0,
1259      9  54,    0,   55,    0,   56,    0,   11,    0,    0,    0,
1260      9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
1261       DATA ((KFPR(I,J),J=1,2),I=201,240)/
1262      &  1000011,   1000011,   2000011,   2000011,   1000011,
1263      &  2000011,   1000013,   1000013,   2000013,   2000013,
1264      &  1000013,   2000013,   1000015,   1000015,   2000015,
1265      &  2000015,   1000015,   2000015,   1000011,   1000012,
1266      1  1000015,   1000016,   2000015,   1000016,   1000012,
1267      1  1000012,   1000016,   1000016,         0,         0,
1268      1  1000022,   1000022,   1000023,   1000023,   1000025,
1269      1  1000025,   1000035,   1000035,   1000022,   1000023,
1270      2  1000022,   1000025,   1000022,   1000035,   1000023,
1271      2  1000025,   1000023,   1000035,   1000025,   1000035,
1272      2  1000024,   1000024,   1000037,   1000037,   1000024,
1273      2  1000037,   1000022,   1000024,   1000023,   1000024,
1274      3  1000025,   1000024,   1000035,   1000024,   1000022,
1275      3  1000037,   1000023,   1000037,   1000025,   1000037,
1276      3  1000035,   1000037,   1000021,   1000022,   1000021,
1277      3  1000023,   1000021,   1000025,   1000021,   1000035/
1278       DATA ((KFPR(I,J),J=1,2),I=241,280)/
1279      4  1000021,   1000024,   1000021,   1000037,   1000021,
1280      4  1000021,   1000021,   1000021,         0,         0,
1281      4  1000002,   1000022,   2000002,   1000022,   1000002,
1282      4  1000023,   2000002,   1000023,   1000002,   1000025,
1283      5  2000002,   1000025,   1000002,   1000035,   2000002,
1284      5  1000035,   1000001,   1000024,   2000005,   1000024,
1285      5  1000001,   1000037,   2000005,   1000037,   1000002,
1286      5  1000021,   2000002,   1000021,         0,         0,
1287      6  1000006,   1000006,   2000006,   2000006,   1000006,
1288      6  2000006,   1000006,   1000006,   2000006,   2000006,
1289      6        0,         0,         0,         0,         0,
1290      6        0,         0,         0,         0,         0,
1291      7  1000002,   1000002,   2000002,   2000002,   1000002,
1292      7  2000002,   1000002,   1000002,   2000002,   2000002,
1293      7  1000002,   2000002,   1000002,   1000002,   2000002,
1294      7  2000002,   1000002,   1000002,   2000002,   2000002/
1295       DATA ((KFPR(I,J),J=1,2),I=281,500)/440*0/
1296       DATA COEF/10000*0D0/
1297       DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1298      &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,
1299      &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,
1300      &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,
1301      &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,
1302      &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,
1303      &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,
1304      &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,
1305      &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,
1306      &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,
1307      &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/
1308
1309 C...Treatment of resonances.
1310       DATA (MWID(I)  ,I=   1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,
1311      &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/
1312
1313 C...Character constants: name of processes.
1314       DATA PROC(0)/                    'All included subprocesses   '/
1315       DATA (PROC(I),I=1,20)/
1316      &'f + fbar -> gamma*/Z0       ',  'f + fbar'' -> W+/-           ',
1317      &'f + fbar -> h0              ',  'gamma + W+/- -> W+/-        ',
1318      &'Z0 + Z0 -> h0               ',  'Z0 + W+/- -> W+/-           ',
1319      &'                            ',  'W+ + W- -> h0               ',
1320      &'                            ',  'f + f'' -> f + f'' (QFD)      ',
1321      1'f + f'' -> f + f'' (QCD)      ','f + fbar -> f'' + fbar''      ',
1322      1'f + fbar -> g + g           ',  'f + fbar -> g + gamma       ',
1323      1'f + fbar -> g + Z0          ',  'f + fbar'' -> g + W+/-       ',
1324      1'f + fbar -> g + h0          ',  'f + fbar -> gamma + gamma   ',
1325      1'f + fbar -> gamma + Z0      ',  'f + fbar'' -> gamma + W+/-   '/
1326       DATA (PROC(I),I=21,40)/
1327      2'f + fbar -> gamma + h0      ',  'f + fbar -> Z0 + Z0         ',
1328      2'f + fbar'' -> Z0 + W+/-      ', 'f + fbar -> Z0 + h0         ',
1329      2'f + fbar -> W+ + W-         ',  'f + fbar'' -> W+/- + h0      ',
1330      2'f + fbar -> h0 + h0         ',  'f + g -> f + g              ',
1331      2'f + g -> f + gamma          ',  'f + g -> f + Z0             ',
1332      3'f + g -> f'' + W+/-          ', 'f + g -> f + h0             ',
1333      3'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',
1334      3'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',
1335      3'f + gamma -> f + h0         ',  'f + Z0 -> f + g             ',
1336      3'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/
1337       DATA (PROC(I),I=41,60)/
1338      4'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + h0            ',
1339      4'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',
1340      4'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',
1341      4'f + W+/- -> f'' + h0         ', 'f + h0 -> f + g             ',
1342      4'f + h0 -> f + gamma         ',  'f + h0 -> f + Z0            ',
1343      5'f + h0 -> f'' + W+/-         ', 'f + h0 -> f + h0            ',
1344      5'g + g -> f + fbar           ',  'g + gamma -> f + fbar       ',
1345      5'g + Z0 -> f + fbar          ',  'g + W+/- -> f + fbar''       ',
1346      5'g + h0 -> f + fbar          ',  'gamma + gamma -> f + fbar   ',
1347      5'gamma + Z0 -> f + fbar      ',  'gamma + W+/- -> f + fbar''   '/
1348       DATA (PROC(I),I=61,80)/
1349      6'gamma + h0 -> f + fbar      ',  'Z0 + Z0 -> f + fbar         ',
1350      6'Z0 + W+/- -> f + fbar''      ', 'Z0 + h0 -> f + fbar         ',
1351      6'W+ + W- -> f + fbar         ',  'W+/- + h0 -> f + fbar''      ',
1352      6'h0 + h0 -> f + fbar         ',  'g + g -> g + g              ',
1353      6'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> Z0 + W+/-   ',
1354      7'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',
1355      7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + h0          ',
1356      7'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',
1357      7'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + h0 -> W+/- + h0      ',
1358      7'h0 + h0 -> h0 + h0          ',  'q + gamma -> q'' + pi+/-     '/
1359       DATA (PROC(I),I=81,100)/
1360      8'q + qbar -> Q + Qbar, mass  ',  'g + g -> Q + Qbar, massive  ',
1361      8'f + q -> f'' + Q, massive    ', 'g + gamma -> Q + Qbar, mass ',
1362      8'gamma + gamma -> F + Fbar, m',  'g + g -> J/Psi + g          ',
1363      8'g + g -> chi_0c + g         ',  'g + g -> chi_1c + g         ',
1364      8'g + g -> chi_2c + g         ',  '                            ',
1365      9'Elastic scattering          ',  'Single diffractive (XB)     ',
1366      9'Single diffractive (AX)     ',  'Double  diffractive         ',
1367      9'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',
1368      9'                            ',  '                            ',
1369      9'                            ',  '                            '/
1370       DATA (PROC(I),I=101,120)/
1371      &'g + g -> gamma*/Z0          ',  'g + g -> h0                 ',
1372      &'gamma + gamma -> h0         ',  '                            ',
1373      &'                            ',  'g + g -> J/Psi + gamma      ',
1374      &'gamma + g -> J/Psi + g      ',  'gamma+gamma -> J/Psi + gamma',
1375      &'                            ',  'f + fbar -> gamma + h0      ',
1376      1'f + fbar -> g + h0          ',  'q + g -> q + h0             ',
1377      1'g + g -> g + h0             ',  'g + g -> gamma + gamma      ',
1378      1'g + g -> g + gamma          ',  'g + g -> gamma + Z0         ',
1379      1'g + g -> Z0 + Z0            ',  'g + g -> W+ + W-            ',
1380      1'                            ',  '                            '/
1381       DATA (PROC(I),I=121,140)/
1382      2'g + g -> Q + Qbar + h0      ',  'q + qbar -> Q + Qbar + h0   ',
1383      2'f + f'' -> f + f'' + h0       ',
1384      2'f + f'' -> f" + f"'' + h0     ',
1385      2'                            ',  '                            ',
1386      2'                            ',  '                            ',
1387      2'                            ',  '                            ',
1388      3'g + g -> Z0 + q + qbar      ',  '                            ',
1389      3'                            ',  '                            ',
1390      3'                            ',  '                            ',
1391      3'                            ',  '                            ',
1392      3'                            ',  '                            '/
1393       DATA (PROC(I),I=141,160)/
1394      4'f + fbar -> gamma*/Z0/Z''0   ', 'f + fbar'' -> W''+/-          ',
1395      4'f + fbar'' -> H+/-           ', 'f + fbar'' -> R              ',
1396      4'q + l -> LQ                 ',  '                            ',
1397      4'd + g -> d*                 ',  'u + g -> u*                 ',
1398      4'g + g -> eta_techni         ',  '                            ',
1399      5'f + fbar -> H0              ',  'g + g -> H0                 ',
1400      5'gamma + gamma -> H0         ',  '                            ',
1401      5'                            ',  'f + fbar -> A0              ',
1402      5'g + g -> A0                 ',  'gamma + gamma -> A0         ',
1403      5'                            ',  '                            '/
1404       DATA (PROC(I),I=161,180)/
1405      6'f + g -> f'' + H+/-          ', 'q + g -> LQ + lbar          ',
1406      6'g + g -> LQ + LQbar         ',  'q + qbar -> LQ + LQbar      ',
1407      6'f + fbar -> f'' + fbar'' (g/Z)',
1408      6'f +fbar'' -> f" + fbar"'' (W) ',
1409      6'q + q'' -> q" + d*           ',  'q + q'' -> q" + u*           ',
1410      6'                            ',  '                            ',
1411      7'f + fbar -> Z0 + H0         ', 'f + fbar'' -> W+/- + H0      ',
1412      7'f + f'' -> f + f'' + H0       ',
1413      7'f + f'' -> f" + f"'' + H0     ',
1414      7'                            ',  'f + fbar -> Z0 + A0         ',
1415      7'f + fbar'' -> W+/- + A0      ',
1416      7'f + f'' -> f + f'' + A0       ',
1417      7'f + f'' -> f" + f"'' + A0     ',
1418      7'                            '/
1419       DATA (PROC(I),I=181,200)/
1420      8'g + g -> Q + Qbar + H0      ',  'q + qbar -> Q + Qbar + H0   ',
1421      8'                            ',  '                            ',
1422      8'                            ',  'g + g -> Q + Qbar + A0      ',
1423      8'q + qbar -> Q + Qbar + A0   ',  '                            ',
1424      8'                            ',  '                            ',
1425      9'f + fbar -> rho_tech0       ',  'f + f'' -> rho_tech+/-       ',
1426      9'f + fbar -> omega_tech0     ',  'f+fbar -> f''+fbar'' (technic)',
1427      9'                            ',  '                            ',
1428      9'                            ',  '                            ',
1429      9'                            ',  '                            '/
1430       DATA (PROC(I),I=201,220)/
1431      &'f + fbar -> ~e_L + ~e_Lbar  ',  'f + fbar -> ~e_R + ~e_Rbar  ',
1432      &'f + fbar -> ~e_R + ~e_Lbar  ',  'f + fbar -> ~mu_L + ~mu_Lbar',
1433      &'f + fbar -> ~mu_R + ~mu_Rbar',  'f + fbar -> ~mu_L + ~mu_Rbar',
1434      &'f+fbar -> ~tau_1 + ~tau_1bar',  'f+fbar -> ~tau_2 + ~tau_2bar',
1435      &'f+fbar -> ~tau_1 + ~tau_2bar',  'q + qbar'' -> ~l_L + ~nulbar ',
1436      1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1437      1'f + fbar -> ~nul + ~nulbar  ',  'f+fbar -> ~nutau + ~nutaubar',
1438      1'                            ',  'f + fbar -> ~chi1 + ~chi1   ',
1439      1'f + fbar -> ~chi2 + ~chi2   ',  'f + fbar -> ~chi3 + ~chi3   ',
1440      1'f + fbar -> ~chi4 + ~chi4   ',  'f + fbar -> ~chi1 + ~chi2   '/
1441       DATA (PROC(I),I=221,240)/
1442      2'f + fbar -> ~chi1 + ~chi3   ',  'f + fbar -> ~chi1 + ~chi4   ',
1443      2'f + fbar -> ~chi2 + ~chi3   ',  'f + fbar -> ~chi2 + ~chi4   ',
1444      2'f + fbar -> ~chi3 + ~chi4   ',  'f+fbar -> ~chi+-1 + ~chi-+1 ',
1445      2'f+fbar -> ~chi+-2 + ~chi-+2 ',  'f+fbar -> ~chi+-1 + ~chi-+2 ',
1446      2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1447      3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1448      3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1449      3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1450      3'q + qbar -> ~chi1 + ~g      ',  'q + qbar -> ~chi2 + ~g      ',
1451      3'q + qbar -> ~chi3 + ~g      ',  'q + qbar -> ~chi4 + ~g      '/
1452       DATA (PROC(I),I=241,260)/
1453      4'q + qbar'' -> ~chi+-1 + ~g   ', 'q + qbar'' -> ~chi+-2 + ~g  ',
1454      4'q + qbar -> ~g + ~g         ',  'g + g -> ~g + ~g            ',
1455      4'                            ',  'qj + g -> ~qj_L + ~chi1     ',
1456      4'qj + g -> ~qj_R + ~chi1     ',  'qj + g -> ~qj_L + ~chi2     ',
1457      4'qj + g -> ~qj_R + ~chi2     ',  'qj + g -> ~qj_L + ~chi3     ',
1458      5'qj + g -> ~qj_R + ~chi3     ',  'qj + g -> ~qj_L + ~chi4     ',
1459      5'qj + g -> ~qj_R + ~chi4     ',  'qj + g -> ~qk_L + ~chi+-1   ',
1460      5'qj + g -> ~qk_R + ~chi+-1   ',  'qj + g -> ~qk_L + ~chi+-2   ',
1461      5'qj + g -> ~qk_R + ~chi+-2   ',  'qj + g -> ~qj_L + ~g        ',
1462      5'qj + g -> ~qj_R + ~g        ',  '                            '/
1463       DATA (PROC(I),I=261,280)/
1464      6'f + fbar -> ~t_1 + ~t_1bar  ',  'f + fbar -> ~t_2 + ~t_2bar  ',
1465      6'f + fbar -> ~t_1 + ~t_2bar  ',  'g + g -> ~t_1 + ~t_1bar     ',
1466      6'g + g -> ~t_2 + ~t_2bar     ',  '                            ',
1467      6'                            ',  '                            ',
1468      6'                            ',  '                            ',
1469      7'qi + qj -> ~qi_L + ~qj_L    ',  'qi + qj -> ~qi_R + ~qj_R    ',
1470      7'qi + qj -> ~qi_L + ~qj_R    ',  'qi+qjbar -> ~qi_L + ~qj_Lbar',
1471      7'qi+qjbar -> ~qi_R + ~qj_Rbar',  'qi+qjbar -> ~qi_L + ~qj_Rbar',
1472      7'f + fbar -> ~qi_L + ~qi_Lbar',  'f + fbar -> ~qi_R + ~qi_Rbar',
1473      7'g + g -> ~qi_L + ~qi_Lbar   ',  'g + g -> ~qi_R + ~qi_Rbar   '/
1474       DATA (PROC(I),I=281,500)/220*'                            '/
1475
1476 C...Cross sections and slope offsets.
1477       DATA SIGT/294*0D0/
1478
1479 C...Supersymmetry switches and parameters.
1480       DATA IMSS/0,
1481      &  0,  0,  0,  1,  0,  0,  0,  1,  0,  0,
1482      1  89*0/
1483       DATA RMSS/0D0,
1484      &  80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
1485      1  700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
1486      2   1D0,800D0,1D4,1D4,1D4,0D0,0D0,24D17,2*0D0,
1487      3  69*0D0/
1488
1489 C...Data for histogramming routines.
1490       DATA IHIST/1000,20000,55,1/
1491       DATA INDX/1000*0/
1492
1493       END
1494
1495 C*********************************************************************
1496
1497 *$ CREATE PYTEST.FOR
1498 *COPY PYTEST
1499 C...PYTEST
1500 C...A simple program (disguised as subroutine) to run at installation
1501 C...as a check that the program works as intended.
1502
1503       SUBROUTINE PYTEST(MTEST)
1504
1505 C...Double precision and integer declarations.
1506       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1507       INTEGER PYK,PYCHGE,PYCOMP
1508 C...Commonblocks.
1509       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1510       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1511       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1512       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
1513       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
1514       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
1515       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
1516 C...Local arrays.
1517       DIMENSION PSUM(5),PINI(6),PFIN(6)
1518
1519 C...Save defaults for values that are changed.
1520       MSTJ1=MSTJ(1)
1521       MSTJ3=MSTJ(3)
1522       MSTJ11=MSTJ(11)
1523       MSTJ42=MSTJ(42)
1524       MSTJ43=MSTJ(43)
1525       MSTJ44=MSTJ(44)
1526       PARJ17=PARJ(17)
1527       PARJ22=PARJ(22)
1528       PARJ43=PARJ(43)
1529       PARJ54=PARJ(54)
1530       MST101=MSTJ(101)
1531       MST104=MSTJ(104)
1532       MST105=MSTJ(105)
1533       MST107=MSTJ(107)
1534       MST116=MSTJ(116)
1535
1536 C...First part: loop over simple events to be generated.
1537       IF(MTEST.GE.1) CALL PYTABU(20)
1538       NERR=0
1539       DO 180 IEV=1,500
1540
1541 C...Reset parameter values. Switch on some nonstandard features.
1542         MSTJ(1)=1
1543         MSTJ(3)=0
1544         MSTJ(11)=1
1545         MSTJ(42)=2
1546         MSTJ(43)=4
1547         MSTJ(44)=2
1548         PARJ(17)=0.1D0
1549         PARJ(22)=1.5D0
1550         PARJ(43)=1D0
1551         PARJ(54)=-0.05D0
1552         MSTJ(101)=5
1553         MSTJ(104)=5
1554         MSTJ(105)=0
1555         MSTJ(107)=1
1556         IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
1557
1558 C...Ten events each for some single jets configurations.
1559         IF(IEV.LE.50) THEN
1560           ITY=(IEV+9)/10
1561           MSTJ(3)=-1
1562           IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
1563           IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
1564           IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
1565           IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
1566           IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
1567           IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
1568
1569 C...Ten events each for some simple jet systems; string fragmentation.
1570         ELSEIF(IEV.LE.130) THEN
1571           ITY=(IEV-41)/10
1572           IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
1573           IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
1574           IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
1575           IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
1576           IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
1577           IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
1578           IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
1579           IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
1580      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1581
1582 C...Seventy events with independent fragmentation and momentum cons.
1583         ELSEIF(IEV.LE.200) THEN
1584           ITY=1+(IEV-131)/16
1585           MSTJ(2)=1+MOD(IEV-131,4)
1586           MSTJ(3)=1+MOD((IEV-131)/4,4)
1587           IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
1588           IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
1589           IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
1590      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1591           IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
1592      &    0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
1593
1594 C...A hundred events with random jets (check invariant mass).
1595         ELSEIF(IEV.LE.300) THEN
1596   100     DO 110 J=1,5
1597             PSUM(J)=0D0
1598   110     CONTINUE
1599           NJET=2D0+6D0*PYR(0)
1600           DO 130 I=1,NJET
1601             KFL=21
1602             IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
1603             IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
1604             EJET=5D0+20D0*PYR(0)
1605             THETA=ACOS(2D0*PYR(0)-1D0)
1606             PHI=6.2832D0*PYR(0)
1607             IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
1608             IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
1609             IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
1610             IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
1611             DO 120 J=1,4
1612               PSUM(J)=PSUM(J)+P(I,J)
1613   120       CONTINUE
1614   130     CONTINUE
1615           IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
1616      &    (PSUM(5)+PARJ(32))**2) GOTO 100
1617
1618 C...Fifty e+e- continuum events with matrix elements.
1619         ELSEIF(IEV.LE.350) THEN
1620           MSTJ(101)=2
1621           CALL PYEEVT(0,40D0)
1622
1623 C...Fifty e+e- continuum event with varying shower options.
1624         ELSEIF(IEV.LE.400) THEN
1625           MSTJ(42)=1+MOD(IEV,2)
1626           MSTJ(43)=1+MOD(IEV/2,4)
1627           MSTJ(44)=MOD(IEV/8,3)
1628           CALL PYEEVT(0,90D0)
1629
1630 C...Fifty e+e- continuum events with coherent shower.
1631         ELSEIF(IEV.LE.450) THEN
1632           CALL PYEEVT(0,500D0)
1633
1634 C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
1635         ELSE
1636           CALL PYONIA(5,9.46D0)
1637         ENDIF
1638
1639 C...Generate event. Find total momentum, energy and charge.
1640         DO 140 J=1,4
1641           PINI(J)=PYP(0,J)
1642   140   CONTINUE
1643         PINI(6)=PYP(0,6)
1644         CALL PYEXEC
1645         DO 150 J=1,4
1646           PFIN(J)=PYP(0,J)
1647   150   CONTINUE
1648         PFIN(6)=PYP(0,6)
1649
1650 C...Check conservation of energy, momentum and charge;
1651 C...usually exact, but only approximate for single jets.
1652         MERR=0
1653         IF(IEV.LE.50) THEN
1654           IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.4D0)
1655      &    MERR=MERR+1
1656           EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
1657           IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
1658           IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
1659         ELSE
1660           DO 160 J=1,4
1661             IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
1662   160     CONTINUE
1663           IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
1664         ENDIF
1665         IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1666      &  (PFIN(J),J=1,4),PFIN(6)
1667
1668 C...Check that all KF codes are known ones, and that partons/particles
1669 C...satisfy energy-momentum-mass relation. Store particle statistics.
1670         DO 170 I=1,N
1671           IF(K(I,1).GT.20) GOTO 170
1672           IF(PYCOMP(K(I,2)).EQ.0) THEN
1673             WRITE(MSTU(11),5100) I
1674             MERR=MERR+1
1675           ENDIF
1676           PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
1677           IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
1678      &    THEN
1679             WRITE(MSTU(11),5200) I
1680             MERR=MERR+1
1681           ENDIF
1682   170   CONTINUE
1683         IF(MTEST.GE.1) CALL PYTABU(21)
1684
1685 C...List all erroneous events and some normal ones.
1686         IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
1687           IF(MERR.GE.1) WRITE(MSTU(11),6400)
1688           CALL PYLIST(2)
1689         ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
1690           CALL PYLIST(1)
1691         ENDIF
1692
1693 C...Stop execution if too many errors.
1694         IF(MERR.NE.0) NERR=NERR+1
1695         IF(NERR.GE.10) THEN
1696           WRITE(MSTU(11),6300)
1697           CALL PYLIST(1)
1698           STOP
1699         ENDIF
1700   180 CONTINUE
1701
1702 C...Summarize result of run.
1703       IF(MTEST.GE.1) CALL PYTABU(22)
1704
1705 C...Reset commonblock variables changed during run.
1706       MSTJ(1)=MSTJ1
1707       MSTJ(3)=MSTJ3
1708       MSTJ(11)=MSTJ11
1709       MSTJ(42)=MSTJ42
1710       MSTJ(43)=MSTJ43
1711       MSTJ(44)=MSTJ44
1712       PARJ(17)=PARJ17
1713       PARJ(22)=PARJ22
1714       PARJ(43)=PARJ43
1715       PARJ(54)=PARJ54
1716       MSTJ(101)=MST101
1717       MSTJ(104)=MST104
1718       MSTJ(105)=MST105
1719       MSTJ(107)=MST107
1720       MSTJ(116)=MST116
1721
1722 C...Second part: complete events of various kinds.
1723 C...Common initial values. Loop over initiating conditions.
1724       MSTP(122)=MAX(0,MIN(2,MTEST))
1725       MDCY(PYCOMP(111),1)=0
1726       DO 230 IPROC=1,8
1727
1728 C...Reset process type, kinematics cuts, and the flags used.
1729         MSEL=0
1730         DO 190 ISUB=1,500
1731           MSUB(ISUB)=0
1732   190   CONTINUE
1733         CKIN(1)=2D0
1734         CKIN(3)=0D0
1735         MSTP(2)=1
1736         MSTP(11)=0
1737         MSTP(33)=0
1738         MSTP(81)=1
1739         MSTP(82)=1
1740         MSTP(111)=1
1741         MSTP(131)=0
1742         MSTP(133)=0
1743         PARP(131)=0.01D0
1744
1745 C...Prompt photon production at fixed target.
1746         IF(IPROC.EQ.1) THEN
1747           PZSUM=300D0
1748           PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
1749           PQSUM=2D0
1750           MSEL=10
1751           CKIN(3)=5D0
1752           CALL PYINIT('FIXT','pi+','p',PZSUM)
1753
1754 C...QCD processes at ISR energies.
1755         ELSEIF(IPROC.EQ.2) THEN
1756           PESUM=63D0
1757           PZSUM=0D0
1758           PQSUM=2D0
1759           MSEL=1
1760           CKIN(3)=5D0
1761           CALL PYINIT('CMS','p','p',PESUM)
1762
1763 C...W production + multiple interactions at CERN Collider.
1764         ELSEIF(IPROC.EQ.3) THEN
1765           PESUM=630D0
1766           PZSUM=0D0
1767           PQSUM=0D0
1768           MSEL=12
1769           CKIN(1)=20D0
1770           MSTP(82)=4
1771           MSTP(2)=2
1772           MSTP(33)=3
1773           CALL PYINIT('CMS','p','pbar',PESUM)
1774
1775 C...W/Z gauge boson pairs + pileup events at the Tevatron.
1776         ELSEIF(IPROC.EQ.4) THEN
1777           PESUM=1800D0
1778           PZSUM=0D0
1779           PQSUM=0D0
1780           MSUB(22)=1
1781           MSUB(23)=1
1782           MSUB(25)=1
1783           CKIN(1)=200D0
1784           MSTP(111)=0
1785           MSTP(131)=1
1786           MSTP(133)=2
1787           PARP(131)=0.04D0
1788           CALL PYINIT('CMS','p','pbar',PESUM)
1789
1790 C...Higgs production at LHC.
1791         ELSEIF(IPROC.EQ.5) THEN
1792           PESUM=15400D0
1793           PZSUM=0D0
1794           PQSUM=2D0
1795           MSUB(3)=1
1796           MSUB(102)=1
1797           MSUB(123)=1
1798           MSUB(124)=1
1799           PMAS(25,1)=300D0
1800           CKIN(1)=200D0
1801           MSTP(81)=0
1802           MSTP(111)=0
1803           CALL PYINIT('CMS','p','p',PESUM)
1804
1805 C...Z' production at SSC.
1806         ELSEIF(IPROC.EQ.6) THEN
1807           PESUM=40000D0
1808           PZSUM=0D0
1809           PQSUM=2D0
1810           MSEL=21
1811           PMAS(32,1)=600D0
1812           CKIN(1)=400D0
1813           MSTP(81)=0
1814           MSTP(111)=0
1815           CALL PYINIT('CMS','p','p',PESUM)
1816
1817 C...W pair production at 1 TeV e+e- collider.
1818         ELSEIF(IPROC.EQ.7) THEN
1819           PESUM=1000D0
1820           PZSUM=0D0
1821           PQSUM=0D0
1822           MSUB(25)=1
1823           MSUB(69)=1
1824           MSTP(11)=1
1825           CALL PYINIT('CMS','e+','e-',PESUM)
1826
1827 C...Deep inelastic scattering at a LEP+LHC ep collider.
1828         ELSEIF(IPROC.EQ.8) THEN
1829           P(1,1)=0D0
1830           P(1,2)=0D0
1831           P(1,3)=8000D0
1832           P(2,1)=0D0
1833           P(2,2)=0D0
1834           P(2,3)=-80D0
1835           PESUM=8080D0
1836           PZSUM=7920D0
1837           PQSUM=0D0
1838           MSUB(10)=1
1839           CKIN(3)=50D0
1840           MSTP(111)=0
1841           CALL PYINIT('USER','p','e-',PESUM)
1842         ENDIF
1843
1844 C...Generate 20 events of each required type.
1845         DO 220 IEV=1,20
1846           CALL PYEVNT
1847           PESUMM=PESUM
1848           IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
1849
1850 C...Check conservation of energy/momentum/flavour.
1851           PINI(1)=0D0
1852           PINI(2)=0D0
1853           PINI(3)=PZSUM
1854           PINI(4)=PESUMM
1855           PINI(6)=PQSUM
1856           DO 200 J=1,4
1857             PFIN(J)=PYP(0,J)
1858   200     CONTINUE
1859           PFIN(6)=PYP(0,6)
1860           MERR=0
1861           DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
1862           DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
1863           DEVQ=ABS(PFIN(6)-PINI(6))
1864           IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
1865      &    DEVQ.GT.0.1D0) MERR=1
1866           IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
1867      &    (PFIN(J),J=1,4),PFIN(6)
1868
1869 C...Check that all KF codes are known ones, and that partons/particles
1870 C...satisfy energy-momentum-mass relation.
1871           DO 210 I=1,N
1872             IF(K(I,1).GT.20) GOTO 210
1873             IF(PYCOMP(K(I,2)).EQ.0) THEN
1874               WRITE(MSTU(11),5100) I
1875               MERR=MERR+1
1876             ENDIF
1877             PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
1878      &      SIGN(1D0,P(I,5))
1879             IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
1880      &      .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
1881               WRITE(MSTU(11),5200) I
1882               MERR=MERR+1
1883             ENDIF
1884   210     CONTINUE
1885
1886 C...Listing of erroneous events, and first event of each type.
1887           IF(MERR.GE.1) NERR=NERR+1
1888           IF(NERR.GE.10) THEN
1889             WRITE(MSTU(11),6300)
1890             CALL PYLIST(1)
1891             STOP
1892           ENDIF
1893           IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
1894             IF(MERR.GE.1) WRITE(MSTU(11),6400)
1895             CALL PYLIST(1)
1896           ENDIF
1897   220   CONTINUE
1898
1899 C...List statistics for each process type.
1900         IF(MTEST.GE.1) CALL PYSTAT(1)
1901   230 CONTINUE
1902
1903 C...Summarize result of run.
1904       IF(NERR.EQ.0) WRITE(MSTU(11),6500)
1905       IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
1906
1907 C...Format statements for output.
1908  5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
1909      &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
1910      &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
1911      &4(1X,F12.5),1X,F8.2)
1912  5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
1913  5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
1914      &'kinematics')
1915  6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
1916      &'wrong.'/5X,'Execution will be stopped after listing of event.')
1917  6400 FORMAT(5X,'Faulty event follows:')
1918  6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
1919  6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
1920      &5X,'This should not have happened!')
1921
1922       RETURN
1923       END
1924
1925 C*********************************************************************
1926
1927 *$ CREATE PYHEPC.FOR
1928 *COPY PYHEPC
1929 C...PYHEPC
1930 C...Converts PYTHIA event record contents to or from
1931 C...the standard event record commonblock.
1932
1933       SUBROUTINE PYHEPC(MCONV)
1934
1935 C...Double precision and integer declarations.
1936       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
1937       INTEGER PYK,PYCHGE,PYCOMP
1938 C...Commonblocks.
1939       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
1940       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
1941       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
1942       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
1943 C...HEPEVT commonblock.
1944       PARAMETER (NMXHEP=4000)
1945       COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
1946      &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
1947       DOUBLE PRECISION PHEP,VHEP
1948       SAVE /HEPEVT/
1949
1950 C...Conversion from PYTHIA to standard, the easy part.
1951       IF(MCONV.EQ.1) THEN
1952         NEVHEP=0
1953         IF(N.GT.NMXHEP) CALL PYERRM(8,
1954      &  '(PYHEPC:) no more space in /HEPEVT/')
1955         NHEP=MIN(N,NMXHEP)
1956         DO 140 I=1,NHEP
1957           ISTHEP(I)=0
1958           IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
1959           IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
1960           IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
1961           IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
1962           IDHEP(I)=K(I,2)
1963           JMOHEP(1,I)=K(I,3)
1964           JMOHEP(2,I)=0
1965           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
1966             JDAHEP(1,I)=K(I,4)
1967             JDAHEP(2,I)=K(I,5)
1968           ELSE
1969             JDAHEP(1,I)=0
1970             JDAHEP(2,I)=0
1971           ENDIF
1972           DO 100 J=1,5
1973             PHEP(J,I)=P(I,J)
1974   100     CONTINUE
1975           DO 110 J=1,4
1976             VHEP(J,I)=V(I,J)
1977   110     CONTINUE
1978
1979 C...Check if new event (from pileup).
1980           IF(I.EQ.1) THEN
1981             INEW=1
1982           ELSE
1983             IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
1984           ENDIF
1985
1986 C...Fill in missing mother information.
1987           IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
1988             IMO1=I-2
1989             IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0)
1990      &      IMO1=IMO1-1
1991             JMOHEP(1,I)=IMO1
1992             JMOHEP(2,I)=IMO1+1
1993           ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
1994             I1=K(I,3)-1
1995   120       I1=I1+1
1996             IF(I1.GE.I) CALL PYERRM(8,
1997      &      '(PYHEPC:) translation of inconsistent event history')
1998             IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 120
1999             KC=PYCOMP(K(I1,2))
2000             IF(I1.LT.I.AND.KC.EQ.0) GOTO 120
2001             IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120
2002             JMOHEP(2,I)=I1
2003           ELSEIF(K(I,2).EQ.94) THEN
2004             NJET=2
2005             IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2006             IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2007             JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2008             IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2009      &      MOD(K(I+1,4)/MSTU(5),MSTU(5))
2010           ENDIF
2011
2012 C...Fill in missing daughter information.
2013           IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2014             DO 130 I1=JDAHEP(1,I),JDAHEP(2,I)
2015               I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2016               JDAHEP(1,I2)=I
2017   130       CONTINUE
2018           ENDIF
2019           IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140
2020           I1=JMOHEP(1,I)
2021           IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140
2022           IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140
2023           IF(JDAHEP(1,I1).EQ.0) THEN
2024             JDAHEP(1,I1)=I
2025           ELSE
2026             JDAHEP(2,I1)=I
2027           ENDIF
2028   140   CONTINUE
2029         DO 150 I=1,NHEP
2030           IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150
2031           IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2032   150   CONTINUE
2033
2034 C...Conversion from standard to PYTHIA, the easy part.
2035       ELSE
2036         IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2037      &  '(PYHEPC:) no more space in /PYJETS/')
2038         N=MIN(NHEP,MSTU(4))
2039         NKQ=0
2040         KQSUM=0
2041         DO 180 I=1,N
2042           K(I,1)=0
2043           IF(ISTHEP(I).EQ.1) K(I,1)=1
2044           IF(ISTHEP(I).EQ.2) K(I,1)=11
2045           IF(ISTHEP(I).EQ.3) K(I,1)=21
2046           K(I,2)=IDHEP(I)
2047           K(I,3)=JMOHEP(1,I)
2048           K(I,4)=JDAHEP(1,I)
2049           K(I,5)=JDAHEP(2,I)
2050           DO 160 J=1,5
2051             P(I,J)=PHEP(J,I)
2052   160     CONTINUE
2053           DO 170 J=1,4
2054             V(I,J)=VHEP(J,I)
2055   170     CONTINUE
2056           V(I,5)=0D0
2057           IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2058             I1=JDAHEP(1,I)
2059             IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2060      &      PHEP(5,I)/PHEP(4,I)
2061           ENDIF
2062
2063 C...Fill in missing information on colour connection in jet systems.
2064           IF(ISTHEP(I).EQ.1) THEN
2065             KC=PYCOMP(K(I,2))
2066             KQ=0
2067             IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2068             IF(KQ.NE.0) NKQ=NKQ+1
2069             IF(KQ.NE.2) KQSUM=KQSUM+KQ
2070             IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2071               K(I,1)=2
2072             ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2073               IF(K(I+1,2).EQ.21) K(I,1)=2
2074             ENDIF
2075           ENDIF
2076   180   CONTINUE
2077         IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2078      &  '(PYHEPC:) input parton configuration not colour singlet')
2079       ENDIF
2080
2081       END
2082
2083 C*********************************************************************
2084
2085 *$ CREATE PYINIT.FOR
2086 *COPY PYINIT
2087 C...PYINIT
2088 C...Initializes the generation procedure; finds maxima of the
2089 C...differential cross-sections to be used for weighting.
2090
2091       SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2092
2093 C...Double precision and integer declarations.
2094       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2095       INTEGER PYK,PYCHGE,PYCOMP
2096 C...Commonblocks.
2097       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2098       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2099       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2100       COMMON/PYDAT4/CHAF(500,2)
2101       CHARACTER CHAF*16
2102       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2103       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2104       COMMON/PYINT1/MINT(400),VINT(400)
2105       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2106       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2107       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2108      &/PYINT1/,/PYINT2/,/PYINT5/
2109 C...Local arrays and character variables.
2110       DIMENSION ALAMIN(20),NFIN(20)
2111       CHARACTER*(*) FRAME,BEAM,TARGET
2112       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHLH(2)*6
2113
2114 C...Interface to PDFLIB.
2115       COMMON/W50512/QCDL4,QCDL5
2116       SAVE /W50512/
2117       DOUBLE PRECISION VALUE(20),QCDL4,QCDL5
2118       CHARACTER*20 PARM(20)
2119       DATA VALUE/20*0D0/,PARM/20*' '/
2120
2121 C...Data:Lambda and n_f values for parton distributions; months.
2122       DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2123      &14*0.2D0/,NFIN/20*4/
2124       DATA CHLH/'lepton','hadron'/
2125
2126 C...Reset MINT and VINT arrays. Write headers.
2127       DO 100 J=1,400
2128         MINT(J)=0
2129         VINT(J)=0D0
2130   100 CONTINUE
2131       IF(MSTU(12).GE.1) CALL PYLIST(0)
2132       IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2133
2134 C...Maximum 4 generations; set maximum number of allowed flavours.
2135       MSTP(1)=MIN(4,MSTP(1))
2136       MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2137       MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2138
2139 C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2140       DO 120 I=-20,20
2141         VINT(180+I)=0D0
2142         IA=IABS(I)
2143         IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2144           DO 110 J=1,MSTP(1)
2145             IB=2*J-1+MOD(IA,2)
2146             IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2147             IPM=(5-ISIGN(1,I))/2
2148             IDC=J+MDCY(IA,2)+2
2149             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2150      &      VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2151   110     CONTINUE
2152         ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2153           VINT(180+I)=1D0
2154         ENDIF
2155   120 CONTINUE
2156
2157 C...Initialize parton distributions: PDFLIB.
2158       IF(MSTP(52).EQ.2) THEN
2159         PARM(1)='NPTYPE'
2160         VALUE(1)=1
2161         PARM(2)='NGROUP'
2162         VALUE(2)=MSTP(51)/1000
2163         PARM(3)='NSET'
2164         VALUE(3)=MOD(MSTP(51),1000)
2165         PARM(4)='TMAS'
2166         VALUE(4)=PMAS(6,1)
2167         CALL PDFSET(PARM,VALUE)
2168         MINT(93)=1000000+MSTP(51)
2169       ENDIF
2170
2171 C...Choose Lambda value to use in alpha-strong.
2172       MSTU(111)=MSTP(2)
2173       IF(MSTP(3).GE.2) THEN
2174         ALAM=0.2D0
2175         NF=4
2176         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.10) THEN
2177           ALAM=ALAMIN(MSTP(51))
2178           NF=NFIN(MSTP(51))
2179         ELSEIF(MSTP(52).EQ.2) THEN
2180           ALAM=QCDL4
2181           NF=4
2182         ENDIF
2183         PARP(1)=ALAM
2184         PARP(61)=ALAM
2185         PARP(72)=ALAM
2186         PARU(112)=ALAM
2187         MSTU(112)=NF
2188         IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2189       ENDIF
2190
2191 C...Initialize the SUSY generation: couplings, masses,
2192 C...decay modes, branching ratios, and so on.
2193       CALL PYMSIN
2194
2195 C...Initialize widths and partial widths for resonances.
2196       CALL PYINRE
2197 C...Set Z0 mass and width for e+e- routines.
2198       PARJ(123)=PMAS(23,1)
2199       PARJ(124)=PMAS(23,2)
2200
2201 C...Identify beam and target particles and frame of process.
2202       CHFRAM=FRAME//' '
2203       CHBEAM=BEAM//' '
2204       CHTARG=TARGET//' '
2205       CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2206       IF(MINT(65).EQ.1) GOTO 170
2207
2208 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2209 C...For e-gamma allow 2 alternatives.
2210       MINT(121)=1
2211       MINT(123)=MSTP(14)
2212       IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2213         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2214      &  (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
2215         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2216         IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2217      &  (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2218       ENDIF
2219
2220 C...Set up kinematics of process.
2221       CALL PYINKI(0)
2222
2223 C...Precalculate flavour selection weights
2224       CALL PYKFIN
2225
2226 C...Loop over gamma-p or gamma-gamma alternatives.
2227       DO 160 IGA=1,MINT(121)
2228         MINT(122)=IGA
2229
2230 C...Select partonic subprocesses to be included in the simulation.
2231         CALL PYINPR
2232
2233 C...Count number of subprocesses on.
2234         MINT(48)=0
2235         DO 130 ISUB=1,500
2236           IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2237      &    MSUB(ISUB).EQ.1) THEN
2238             WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2239             STOP
2240           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2241             WRITE(MSTU(11),5300) ISUB
2242             STOP
2243           ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2244             WRITE(MSTU(11),5400) ISUB
2245             STOP
2246           ELSEIF(MSUB(ISUB).EQ.1) THEN
2247             MINT(48)=MINT(48)+1
2248           ENDIF
2249   130   CONTINUE
2250         IF(MINT(48).EQ.0) THEN
2251           WRITE(MSTU(11),5500)
2252           STOP
2253         ENDIF
2254         MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2255
2256 C...Reset variables for cross-section calculation.
2257         DO 150 I=0,500
2258           DO 140 J=1,3
2259             NGEN(I,J)=0
2260             XSEC(I,J)=0D0
2261   140     CONTINUE
2262   150   CONTINUE
2263
2264 C...Find parametrized total cross-sections.
2265         CALL PYXTOT
2266
2267 C...Maxima of differential cross-sections.
2268         IF(MSTP(121).LE.1) CALL PYMAXI
2269
2270 C...Initialize possibility of pileup events.
2271         IF(MINT(121).GT.1) MSTP(131)=0
2272         IF(MSTP(131).NE.0) CALL PYPILE(1)
2273
2274 C...Initialize multiple interactions with variable impact parameter.
2275         IF(MINT(50).EQ.1.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND.
2276      &  MSTP(82).GE.2) CALL PYMULT(1)
2277
2278 C...Save results for gamma-p and gamma-gamma alternatives.
2279         IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2280   160 CONTINUE
2281
2282 C...Initialization finished.
2283   170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2284
2285 C...Formats for initialization information.
2286  5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2287      &'routines',1X,17('*'))
2288  5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2289      &'-',A6,' interactions.'/1X,'Execution stopped!')
2290  5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2291      &1X,'Execution stopped!')
2292  5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2293      &1X,'Execution stopped!')
2294  5500 FORMAT(1X,'Error: no subprocess switched on.'/
2295      &1X,'Execution stopped.')
2296  5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2297      &22('*'))
2298
2299       RETURN
2300       END
2301
2302 C*********************************************************************
2303
2304 *$ CREATE PYEVNT.FOR
2305 *COPY PYEVNT
2306 C...PYEVNT
2307 C...Administers the generation of a high-pT event via calls to
2308 C...a number of subroutines.
2309
2310       SUBROUTINE PYEVNT
2311
2312 C...Double precision and integer declarations.
2313       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2314       INTEGER PYK,PYCHGE,PYCOMP
2315 C...Commonblocks.
2316       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2317       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2318       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2319       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2320       COMMON/PYINT1/MINT(400),VINT(400)
2321       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2322       COMMON/PYINT4/MWID(500),WIDS(500,5)
2323       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2324       COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
2325       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,
2326      &/PYINT4/,/PYINT5/,/PYUPPR/
2327 C...Local array.
2328       DIMENSION VTX(4)
2329
2330 C...Initial values for some counters.
2331       N=0
2332       MINT(5)=MINT(5)+1
2333       MINT(7)=0
2334       MINT(8)=0
2335       MINT(83)=0
2336       MINT(84)=MSTP(126)
2337       MSTU(24)=0
2338       MSTU70=0
2339       MSTJ14=MSTJ(14)
2340
2341 C...If variable energies: redo incoming kinematics and cross-section.
2342       MSTI(61)=0
2343       IF(MSTP(171).EQ.1) THEN
2344         CALL PYINKI(1)
2345         IF(MSTI(61).EQ.1) THEN
2346           MINT(5)=MINT(5)-1
2347           RETURN
2348         ENDIF
2349         IF(MINT(121).GT.1) CALL PYSAVE(3,1)
2350         CALL PYXTOT
2351       ENDIF
2352
2353 C...Loop over number of pileup events; check space left.
2354       IF(MSTP(131).LE.0) THEN
2355         NPILE=1
2356       ELSE
2357         CALL PYPILE(2)
2358         NPILE=MINT(81)
2359       ENDIF
2360       DO 260 IPILE=1,NPILE
2361         IF(MINT(84)+100.GE.MSTU(4)) THEN
2362           CALL PYERRM(11,
2363      &    '(PYEVNT:) no more space in PYJETS for pileup events')
2364           IF(MSTU(21).GE.1) GOTO 270
2365         ENDIF
2366         MINT(82)=IPILE
2367
2368 C...Generate variables of hard scattering.
2369         MINT(51)=0
2370         MSTI(52)=0
2371   100   CONTINUE
2372         IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
2373         MINT(31)=0
2374         MINT(51)=0
2375         MINT(57)=0
2376         CALL PYRAND
2377         IF(MSTI(61).EQ.1) THEN
2378           MINT(5)=MINT(5)-1
2379           RETURN
2380         ENDIF
2381         IF(MINT(51).EQ.2) RETURN
2382         ISUB=MINT(1)
2383         IF(MSTP(111).EQ.-1) GOTO 250
2384
2385         IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
2386 C...Hard scattering (including low-pT):
2387 C...reconstruct kinematics and colour flow of hard scattering.
2388   110     MINT(51)=0
2389           CALL PYSCAT
2390           IF(MINT(51).EQ.1) GOTO 100
2391           IPU1=MINT(84)+1
2392           IPU2=MINT(84)+2
2393           IF(ISUB.EQ.95) GOTO 130
2394
2395 C...Showering of initial state partons (optional).
2396           ALAMSV=PARJ(81)
2397           PARJ(81)=PARP(72)
2398           IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2)
2399           PARJ(81)=ALAMSV
2400           IF(MINT(51).EQ.1) GOTO 100
2401
2402 C...Showering of final state partons (optional).
2403           ALAMSV=PARJ(81)
2404           PARJ(81)=PARP(72)
2405           IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
2406      &    THEN
2407             IPU3=MINT(84)+3
2408             IPU4=MINT(84)+4
2409             IF(ISET(ISUB).EQ.5) IPU4=-3
2410             QMAX=VINT(55)
2411             IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
2412             CALL PYSHOW(IPU3,IPU4,QMAX)
2413           ELSEIF(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN
2414             DO 120 IUP=1,NFUP
2415               IPU3=IFUP(IUP,1)+MINT(84)
2416               IPU4=IFUP(IUP,2)+MINT(84)
2417               QMAX=SQRT(MAX(0D0,Q2UP(IUP)))
2418               CALL PYSHOW(IPU3,IPU4,QMAX)
2419   120       CONTINUE
2420           ENDIF
2421           PARJ(81)=ALAMSV
2422
2423 C...Decay of final state resonances.
2424           MINT(32)=0
2425           IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
2426           IF(MINT(51).EQ.1) GOTO 100
2427           MINT(52)=N
2428
2429 C...Multiple interactions.
2430           IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6)
2431           MINT(53)=N
2432
2433 C...Hadron remnants and primordial kT.
2434   130     CALL PYREMN(IPU1,IPU2)
2435           IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO 110
2436           IF(MINT(51).EQ.1) GOTO 100
2437
2438         ELSE
2439 C...Diffractive and elastic scattering.
2440           CALL PYDIFF
2441         ENDIF
2442
2443 C...Check that no odd resonance left undecayed.
2444         IF(MSTP(111).GE.1) THEN
2445           NFIX=N
2446           DO 140 I=MINT(84)+1,NFIX
2447             IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
2448      &      K(I,2).NE.22) THEN
2449               IF(MWID(PYCOMP(K(I,2))).NE.0) THEN
2450                 CALL PYRESD(I)
2451                 IF(MINT(51).EQ.1) GOTO 100
2452               ENDIF
2453             ENDIF
2454   140     CONTINUE
2455         ENDIF
2456
2457 C...Recalculate energies from momenta and masses (if desired).
2458         IF(MSTP(113).GE.1) THEN
2459           DO 150 I=MINT(83)+1,N
2460             IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
2461      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
2462   150     CONTINUE
2463           NRECAL=N
2464         ENDIF
2465
2466 C...Rearrange partons along strings, check invariant mass cuts.
2467         MSTU(28)=0
2468         IF(MSTP(111).LE.0) MSTJ(14)=-1
2469         CALL PYPREP(MINT(84)+1)
2470         MSTJ(14)=MSTJ14
2471         IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
2472         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
2473           DO 180 I=MINT(84)+1,N
2474             IF(K(I,2).EQ.94) THEN
2475               DO 170 I1=I+1,MIN(N,I+3)
2476                 IF(K(I1,3).EQ.I) THEN
2477                   K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
2478                   IF(K(I1,3).EQ.0) THEN
2479                     DO 160 II=MINT(84)+1,I-1
2480                         IF(K(II,2).EQ.K(I1,2)) THEN
2481                           IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
2482      &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
2483                         ENDIF
2484   160               CONTINUE
2485                     IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
2486                   ENDIF
2487                 ENDIF
2488   170         CONTINUE
2489             ENDIF
2490   180     CONTINUE
2491           CALL PYEDIT(12)
2492           CALL PYEDIT(14)
2493           IF(MSTP(125).EQ.0) CALL PYEDIT(15)
2494           IF(MSTP(125).EQ.0) MINT(4)=0
2495           DO 200 I=MINT(83)+1,N
2496             IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
2497               DO 190 I1=I+1,N
2498                 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
2499                 IF(K(I1,3).EQ.I) K(I,5)=I1
2500   190         CONTINUE
2501             ENDIF
2502   200     CONTINUE
2503         ENDIF
2504
2505 C...Introduce separators between sections in PYLIST event listing.
2506         IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
2507           MSTU70=1
2508           MSTU(71)=N
2509         ELSEIF(IPILE.EQ.1) THEN
2510           MSTU70=3
2511           MSTU(71)=2
2512           MSTU(72)=MINT(4)
2513           MSTU(73)=N
2514         ENDIF
2515
2516 C...Go back to lab frame (needed for vertices, also in fragmentation).
2517         CALL PYFRAM(1)
2518
2519 C...Set nonvanishing production vertex (optional).
2520         IF(MSTP(151).EQ.1) THEN
2521           DO 210 J=1,4
2522             VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
2523      &      SIN(PARU(2)*PYR(0))
2524   210     CONTINUE
2525           DO 230 I=MINT(83)+1,N
2526             DO 220 J=1,4
2527               V(I,J)=V(I,J)+VTX(J)
2528   220       CONTINUE
2529   230     CONTINUE
2530         ENDIF
2531
2532 C...Perform hadronization (if desired).
2533         IF(MSTP(111).GE.1) THEN
2534           CALL PYEXEC
2535           IF(MSTU(24).NE.0) GOTO 100
2536         ENDIF
2537         IF(MSTP(113).GE.1) THEN
2538           DO 240 I=NRECAL,N
2539             IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
2540      &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
2541   240     CONTINUE
2542         ENDIF
2543         IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
2544
2545 C...Store event information and calculate Monte Carlo estimates of
2546 C...subprocess cross-sections.
2547   250   IF(IPILE.EQ.1) CALL PYDOCU
2548
2549 C...Set counters for current pileup event and loop to next one.
2550         MSTI(41)=IPILE
2551         IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
2552         IF(MSTU70.LT.10) THEN
2553           MSTU70=MSTU70+1
2554           MSTU(70+MSTU70)=N
2555         ENDIF
2556         MINT(83)=N
2557         MINT(84)=N+MSTP(126)
2558         IF(IPILE.LT.NPILE) CALL PYFRAM(2)
2559   260 CONTINUE
2560
2561 C...Generic information on pileup events. Reconstruct missing history.
2562       IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
2563         PARI(91)=VINT(132)
2564         PARI(92)=VINT(133)
2565         PARI(93)=VINT(134)
2566         IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
2567       ENDIF
2568       CALL PYEDIT(16)
2569
2570 C...Transform to the desired coordinate frame.
2571   270 CALL PYFRAM(MSTP(124))
2572       MSTU(70)=MSTU70
2573       PARU(21)=VINT(1)
2574
2575       RETURN
2576       END
2577
2578 C***********************************************************************
2579
2580 *$ CREATE PYSTAT.FOR
2581 *COPY PYSTAT
2582 C...PYSTAT
2583 C...Prints out information about cross-sections, decay widths, branching
2584 C...ratios, kinematical limits, status codes and parameter values.
2585
2586       SUBROUTINE PYSTAT(MSTAT)
2587
2588 C...Double precision and integer declarations.
2589       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2590       INTEGER PYK,PYCHGE,PYCOMP
2591 C...Parameter statement to help give large particle numbers.
2592       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2593 C...Commonblocks.
2594       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2595       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2596       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2597       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2598       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2599       COMMON/PYINT1/MINT(400),VINT(400)
2600       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2601       COMMON/PYINT4/MWID(500),WIDS(500,5)
2602       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2603       COMMON/PYINT6/PROC(0:500)
2604       CHARACTER PROC*28
2605       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2606       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
2607      &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/
2608 C...Local arrays, character variables and data.
2609       DIMENSION WDTP(0:200),WDTE(0:200,0:5)
2610       CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
2611      &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28
2612       DATA PROGA/
2613      &'VMD/hadron * VMD            ','VMD/hadron * direct         ',
2614      &'VMD/hadron * anomalous      ','direct * direct             ',
2615      &'direct * anomalous          ','anomalous * anomalous       '/
2616       DATA DISGA/'e * VMD','e * anomalous'/
2617       DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
2618      &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
2619      &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
2620      &'     y*_small     ','    eta*_large    ','    eta*_small    ',
2621      &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
2622      &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
2623      &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
2624      &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
2625      &'       tau''       '/
2626
2627 C...Cross-sections.
2628       IF(MSTAT.LE.1) THEN
2629         IF(MINT(121).GT.1) CALL PYSAVE(5,0)
2630         WRITE(MSTU(11),5000)
2631         WRITE(MSTU(11),5100)
2632         WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
2633         DO 100 I=1,500
2634           IF(MSUB(I).NE.1) GOTO 100
2635           WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
2636   100   CONTINUE
2637         IF(MINT(121).GT.1) THEN
2638           WRITE(MSTU(11),5300)
2639           DO 110 IGA=1,MINT(121)
2640             CALL PYSAVE(3,IGA)
2641             IF(MINT(121).EQ.2) THEN
2642               WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
2643      &        XSEC(0,3)
2644             ELSE
2645               WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
2646      &        XSEC(0,3)
2647             ENDIF
2648   110     CONTINUE
2649           CALL PYSAVE(5,0)
2650         ENDIF
2651         WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
2652      &  MAX(1D0,DBLE(NGEN(0,2)))
2653
2654 C...Decay widths and branching ratios.
2655       ELSEIF(MSTAT.EQ.2) THEN
2656         WRITE(MSTU(11),5500)
2657         WRITE(MSTU(11),5600)
2658         DO 140 KC=1,500
2659           KF=KCHG(KC,4)
2660           CALL PYNAME(KF,CHKF)
2661           IOFF=0
2662           IF(KC.LE.22) THEN
2663             IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
2664             IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
2665             IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
2666             IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
2667             IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
2668           ELSE
2669             IF(MWID(KC).LE.0) GOTO 140
2670             IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
2671      &      KF/KSUSY1.EQ.2)) GOTO 140
2672           ENDIF
2673 C...Off-shell branchings.
2674           IF(IOFF.EQ.1) THEN
2675             NGP=0
2676             IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
2677             IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
2678      &      PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
2679             DO 120 J=1,MDCY(KC,3)
2680               IDC=J+MDCY(KC,2)-1
2681               NGP1=0
2682               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2683      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2684               NGP2=0
2685               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2686      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2687               CALL PYNAME(KFDP(IDC,1),CHD1)
2688               CALL PYNAME(KFDP(IDC,2),CHD2)
2689               IF(KFDP(IDC,3).EQ.0) THEN
2690                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2691      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2692      &          CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2693               ELSE
2694                 CALL PYNAME(KFDP(IDC,3),CHD3)
2695                 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
2696      &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2697      &          CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
2698               ENDIF
2699   120       CONTINUE
2700 C...On-shell decays.
2701           ELSE
2702             CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
2703             BRFIN=1D0
2704             IF(WDTE(0,0).LE.0D0) BRFIN=0D0
2705             WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
2706      &      STATE(MDCY(KC,1)),BRFIN
2707             DO 130 J=1,MDCY(KC,3)
2708               IDC=J+MDCY(KC,2)-1
2709               NGP1=0
2710               IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
2711      &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
2712               NGP2=0
2713               IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
2714      &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
2715               BRFIN=0D0
2716               IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
2717               CALL PYNAME(KFDP(IDC,1),CHD1)
2718               CALL PYNAME(KFDP(IDC,2),CHD2)
2719               IF(KFDP(IDC,3).EQ.0) THEN
2720                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2721      &          WRITE(MSTU(11),5800) IDC,CHD1(1:10),
2722      &          CHD2(1:10),WDTP(J),WDTP(J)/WDTP(0),
2723      &          STATE(MDME(IDC,1)),BRFIN
2724               ELSE
2725                 CALL PYNAME(KFDP(IDC,3),CHD3)
2726                 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
2727      &          WRITE(MSTU(11),5900) IDC,CHD1(1:10),
2728      &          CHD2(1:10),CHD3(1:10),WDTP(J),WDTP(J)/WDTP(0),
2729      &          STATE(MDME(IDC,1)),BRFIN
2730               ENDIF
2731   130       CONTINUE
2732           ENDIF
2733   140   CONTINUE
2734         WRITE(MSTU(11),6000)
2735
2736 C...Allowed incoming partons/particles at hard interaction.
2737       ELSEIF(MSTAT.EQ.3) THEN
2738         WRITE(MSTU(11),6100)
2739         CALL PYNAME(MINT(11),CHAU)
2740         CHIN(1)=CHAU(1:12)
2741         CALL PYNAME(MINT(12),CHAU)
2742         CHIN(2)=CHAU(1:12)
2743         WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
2744         DO 150 I=-20,22
2745           IF(I.EQ.0) GOTO 150
2746           IA=IABS(I)
2747           IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
2748           IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
2749           CALL PYNAME(I,CHAU)
2750           WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
2751      &    STATE(KFIN(2,I))
2752   150   CONTINUE
2753         WRITE(MSTU(11),6400)
2754
2755 C...User-defined limits on kinematical variables.
2756       ELSEIF(MSTAT.EQ.4) THEN
2757         WRITE(MSTU(11),6500)
2758         WRITE(MSTU(11),6600)
2759         SHRMAX=CKIN(2)
2760         IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
2761         WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
2762         PTHMIN=MAX(CKIN(3),CKIN(5))
2763         PTHMAX=CKIN(4)
2764         IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
2765         WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
2766         WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
2767         DO 160 I=4,14
2768           WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
2769   160   CONTINUE
2770         SPRMAX=CKIN(32)
2771         IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
2772         WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
2773         WRITE(MSTU(11),7000)
2774
2775 C...Status codes and parameter values.
2776       ELSEIF(MSTAT.EQ.5) THEN
2777         WRITE(MSTU(11),7100)
2778         WRITE(MSTU(11),7200)
2779         DO 170 I=1,100
2780           WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
2781      &    PARP(100+I)
2782   170   CONTINUE
2783
2784 C...List of all processes implemented in the program.
2785       ELSEIF(MSTAT.EQ.6) THEN
2786         WRITE(MSTU(11),7400)
2787         WRITE(MSTU(11),7500)
2788         DO 180 I=1,500
2789           IF(ISET(I).LT.0) GOTO 180
2790           WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
2791   180   CONTINUE
2792         WRITE(MSTU(11),7700)
2793       ENDIF
2794
2795 C...Formats for printouts.
2796  5000 FORMAT('1',9('*'),1X,'PYSTAT:  Statistics on Number of ',
2797      &'Events and Cross-sections',1X,9('*'))
2798  5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
2799      &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
2800      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
2801      &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
2802      &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
2803      &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
2804      &'I',12X,'I')
2805  5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
2806      &D10.3,1X,'I')
2807  5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
2808      &1X,'I',34X,'I',28X,'I',12X,'I')
2809  5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
2810      &1X,'********* Fraction of events that fail fragmentation ',
2811      &'cuts =',1X,F8.5,' *********'/)
2812  5500 FORMAT('1',27('*'),1X,'PYSTAT:  Decay Widths and Branching ',
2813      &'Ratios',1X,27('*'))
2814  5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2815      &1X,'I',5X,'Mother  -->  Branching/Decay Channel',8X,'I',1X,
2816      &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
2817      &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
2818      &1X,98('='))
2819  5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
2820      &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
2821      &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
2822  5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
2823      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2824      &1P,D10.3,0P,1X,'I')
2825  5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
2826      &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
2827      &1P,D10.3,0P,1X,'I')
2828  6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
2829  6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
2830      &'Particles at Hard Interaction',1X,7('*'))
2831  6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
2832      &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
2833      &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
2834      &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
2835      &78('=')/1X,'I',38X,'I',37X,'I')
2836  6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
2837  6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
2838  6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
2839      &'Kinematical Variables',1X,12('*'))
2840  6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
2841  6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
2842      &16X,'I')
2843  6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
2844      &1X,'<',1X,1P,D10.3,0P,16X,'I')
2845  6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
2846  7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
2847  7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
2848      &'Parameter Values',1X,12('*'))
2849  7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
2850      &'PARP(I)'/)
2851  7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
2852  7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
2853      &1X,13('*'))
2854  7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
2855      &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
2856      &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
2857  7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
2858  7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
2859
2860       RETURN
2861       END
2862
2863 C*********************************************************************
2864
2865 *$ CREATE PYINRE.FOR
2866 *COPY PYINRE
2867 C...PYINRE
2868 C...Calculates full and effective widths of gauge bosons, stores
2869 C...masses and widths, rescales coefficients to be used for
2870 C...resonance production generation.
2871
2872       SUBROUTINE PYINRE
2873
2874 C...Double precision and integer declarations.
2875       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2876       INTEGER PYK,PYCHGE,PYCOMP
2877 C...Parameter statement to help give large particle numbers.
2878       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
2879 C...Commonblocks.
2880       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2881       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2882       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
2883       COMMON/PYDAT4/CHAF(500,2)
2884       CHARACTER CHAF*16
2885       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2886       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2887       COMMON/PYINT1/MINT(400),VINT(400)
2888       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2889       COMMON/PYINT4/MWID(500),WIDS(500,5)
2890       COMMON/PYINT6/PROC(0:500)
2891       CHARACTER PROC*28
2892       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
2893       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2894      &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
2895 C...Local arrays and data.
2896       DIMENSION WDTP(0:200),WDTE(0:200,0:5),WDTPM(0:200),
2897      &WDTEM(0:200,0:5),KCORD(500),PMORD(500)
2898
2899 C...Born level couplings in MSSM Higgs doublet sector.
2900       XW=PARU(102)
2901       XWV=XW
2902       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
2903       XW1=1D0-XW
2904       IF(MSTP(4).EQ.2) THEN
2905         TANBE=PARU(141)
2906         RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
2907         SQMZ=PMAS(23,1)**2
2908         SQMW=PMAS(24,1)**2
2909         SQMH=PMAS(25,1)**2
2910         SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
2911         SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
2912         SQMHC=SQMA+SQMW
2913         IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
2914           WRITE(MSTU(11),5000)
2915           STOP
2916         ENDIF
2917         PMAS(35,1)=SQRT(SQMHP)
2918         PMAS(36,1)=SQRT(SQMA)
2919         PMAS(37,1)=SQRT(SQMHC)
2920         ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
2921      &  (SQMA-SQMZ)))
2922         BESU=ATAN(TANBE)
2923         PARU(142)=1D0
2924         PARU(143)=1D0
2925         PARU(161)=-SIN(ALSU)/COS(BESU)
2926         PARU(162)=COS(ALSU)/SIN(BESU)
2927         PARU(163)=PARU(161)
2928         PARU(164)=SIN(BESU-ALSU)
2929         PARU(165)=PARU(164)
2930         PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
2931         PARU(171)=COS(ALSU)/COS(BESU)
2932         PARU(172)=SIN(ALSU)/SIN(BESU)
2933         PARU(173)=PARU(171)
2934         PARU(174)=COS(BESU-ALSU)
2935         PARU(175)=PARU(174)
2936         PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
2937      &  SIN(BESU+ALSU)
2938         PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
2939         PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
2940         PARU(181)=TANBE
2941         PARU(182)=1D0/TANBE
2942         PARU(183)=PARU(181)
2943         PARU(184)=0D0
2944         PARU(185)=PARU(184)
2945         PARU(186)=COS(BESU-ALSU)
2946         PARU(187)=SIN(BESU-ALSU)
2947         PARU(188)=PARU(186)
2948         PARU(189)=PARU(187)
2949         PARU(190)=0D0
2950         PARU(195)=COS(BESU-ALSU)
2951       ENDIF
2952
2953 C...Reset effective widths of gauge bosons.
2954       DO 110 I=1,500
2955         DO 100 J=1,5
2956           WIDS(I,J)=1D0
2957   100   CONTINUE
2958   110 CONTINUE
2959
2960 C...Order resonances by increasing mass (except Z0 and W+/-).
2961       NRES=0
2962       DO 140 KC=1,500
2963         KF=KCHG(KC,4)
2964         IF(KF.EQ.0) GOTO 140
2965         IF(MWID(KC).EQ.0) GOTO 140
2966         IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
2967           IF(MSTP(1).LE.3) GOTO 140
2968         ENDIF
2969         IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
2970           IF(IMSS(1).LE.0) GOTO 140
2971         ENDIF
2972         NRES=NRES+1
2973         PMRES=PMAS(KC,1)
2974         IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
2975         DO 120 I1=NRES-1,1,-1
2976           IF(PMRES.GE.PMORD(I1)) GOTO 130
2977           KCORD(I1+1)=KCORD(I1)
2978           PMORD(I1+1)=PMORD(I1)
2979   120   CONTINUE
2980   130   KCORD(I1+1)=KC
2981         PMORD(I1+1)=PMRES
2982   140 CONTINUE
2983
2984 C...Loop over possible resonances.
2985       DO 180 I=1,NRES
2986         KC=KCORD(I)
2987         KF=KCHG(KC,4)
2988
2989 C...Check that no fourth generation channels on by mistake.
2990         IF(MSTP(1).LE.3) THEN
2991           DO 150 J=1,MDCY(KC,3)
2992             IDC=J+MDCY(KC,2)-1
2993             KFA1=IABS(KFDP(IDC,1))
2994             KFA2=IABS(KFDP(IDC,2))
2995             IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
2996      &      KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
2997      &      MDME(IDC,1)=-1
2998   150     CONTINUE
2999         ENDIF
3000
3001 C...Check that no supersymmetric channels on by mistake.
3002         IF(IMSS(1).LE.0) THEN
3003           DO 160 J=1,MDCY(KC,3)
3004             IDC=J+MDCY(KC,2)-1
3005             KFA1S=IABS(KFDP(IDC,1))/KSUSY1
3006             KFA2S=IABS(KFDP(IDC,2))/KSUSY1
3007             IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
3008      &      MDME(IDC,1)=-1
3009   160     CONTINUE
3010         ENDIF
3011
3012 C...Find mass and evaluate width.
3013         PMR=PMAS(KC,1)
3014         IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
3015         IF(MWID(KC).EQ.3) MINT(63)=1
3016         CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
3017         MINT(51)=0
3018
3019 C...Evaluate suppression factors due to non-simulated channels.
3020         IF(KCHG(KC,3).EQ.0) THEN
3021           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
3022      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3023      &    2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3024           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3025           WIDS(KC,3)=0D0
3026           WIDS(KC,4)=0D0
3027           WIDS(KC,5)=0D0
3028         ELSE
3029           IF(MWID(KC).EQ.3) MINT(63)=1
3030           CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
3031           MINT(51)=0
3032           WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
3033      &    (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
3034      &    (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
3035      &    WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))/WDTP(0)**2
3036           WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
3037           WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0)
3038           WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
3039      &    2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
3040      &    2D0*WDTE(0,4)*WDTE(0,5))/WDTP(0)**2
3041           WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
3042      &    2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
3043      &    2D0*WDTEM(0,4)*WDTEM(0,5))/WDTP(0)**2
3044         ENDIF
3045
3046 C...Set resonance widths and branching ratios;
3047 C...also on/off switch for decays.
3048         IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
3049           PMAS(KC,2)=WDTP(0)
3050           PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
3051           MDCY(KC,1)=MSTP(41)
3052           DO 170 J=1,MDCY(KC,3)
3053             IDC=J+MDCY(KC,2)-1
3054             BRAT(IDC)=0D0
3055             IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
3056   170     CONTINUE
3057         ENDIF
3058   180 CONTINUE
3059
3060 C...Flavours of leptoquark: redefine charge and name.
3061       KFLQQ=KFDP(MDCY(39,2),1)
3062       KFLQL=KFDP(MDCY(39,2),2)
3063       KCHG(39,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
3064      &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
3065       LL=1
3066       IF(IABS(KFLQL).EQ.13) LL=2
3067       IF(IABS(KFLQL).EQ.15) LL=3
3068       CHAF(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
3069      &CHAF(IABS(KFLQL),1)(1:LL)//' '
3070       CHAF(39,2)=CHAF(39,2)(1:4+LL)//'bar '
3071
3072 C...Special cases in treatment of gamma*/Z0: redefine process name.
3073       IF(MSTP(43).EQ.1) THEN
3074         PROC(1)='f + fbar -> gamma*'
3075         PROC(15)='f + fbar -> g + gamma*'
3076         PROC(19)='f + fbar -> gamma + gamma*'
3077         PROC(30)='f + g -> f + gamma*'
3078         PROC(35)='f + gamma -> f + gamma*'
3079       ELSEIF(MSTP(43).EQ.2) THEN
3080         PROC(1)='f + fbar -> Z0'
3081         PROC(15)='f + fbar -> g + Z0'
3082         PROC(19)='f + fbar -> gamma + Z0'
3083         PROC(30)='f + g -> f + Z0'
3084         PROC(35)='f + gamma -> f + Z0'
3085       ELSEIF(MSTP(43).EQ.3) THEN
3086         PROC(1)='f + fbar -> gamma*/Z0'
3087         PROC(15)='f + fbar -> g + gamma*/Z0'
3088         PROC(19)='f + fbar -> gamma + gamma*/Z0'
3089         PROC(30)='f + g -> f + gamma*/Z0'
3090         PROC(35)='f + gamma -> f + gamma*/Z0'
3091       ENDIF
3092
3093 C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
3094       IF(MSTP(44).EQ.1) THEN
3095         PROC(141)='f + fbar -> gamma*'
3096       ELSEIF(MSTP(44).EQ.2) THEN
3097         PROC(141)='f + fbar -> Z0'
3098       ELSEIF(MSTP(44).EQ.3) THEN
3099         PROC(141)='f + fbar -> Z''0'
3100       ELSEIF(MSTP(44).EQ.4) THEN
3101         PROC(141)='f + fbar -> gamma*/Z0'
3102       ELSEIF(MSTP(44).EQ.5) THEN
3103         PROC(141)='f + fbar -> gamma*/Z''0'
3104       ELSEIF(MSTP(44).EQ.6) THEN
3105         PROC(141)='f + fbar -> Z0/Z''0'
3106       ELSEIF(MSTP(44).EQ.7) THEN
3107         PROC(141)='f + fbar -> gamma*/Z0/Z''0'
3108       ENDIF
3109
3110 C...Special cases in treatment of WW -> WW: redefine process name.
3111       IF(MSTP(45).EQ.1) THEN
3112         PROC(77)='W+ + W+ -> W+ + W+'
3113       ELSEIF(MSTP(45).EQ.2) THEN
3114         PROC(77)='W+ + W- -> W+ + W-'
3115       ELSEIF(MSTP(45).EQ.3) THEN
3116         PROC(77)='W+/- + W+/- -> W+/- + W+/-'
3117       ENDIF
3118
3119 C...Format for error information.
3120  5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
3121      &'combination'/1X,'Execution stopped!')
3122
3123       RETURN
3124       END
3125
3126 C*********************************************************************
3127
3128 *$ CREATE PYINBM.FOR
3129 *COPY PYINBM
3130 C...PYINBM
3131 C...Identifies the two incoming particles and the choice of frame.
3132
3133        SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3134
3135 C...Double precision and integer declarations.
3136       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3137       INTEGER PYK,PYCHGE,PYCOMP
3138 C...Commonblocks.
3139       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3140       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3141       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3142       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3143       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3144       COMMON/PYINT1/MINT(400),VINT(400)
3145       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3146 C...Local arrays, character variables and data.
3147       CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26,
3148      &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76
3149       DIMENSION LEN(3),KCDE(29),PM(2)
3150       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
3151      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
3152       DATA CHCDE/'e-      ','e+      ','nu_e    ','nu_ebar ',
3153      &'mu-     ','mu+     ','nu_mu   ','nu_mubar','tau-    ',
3154      &'tau+    ','nu_tau  ','nu_tauba','pi+     ','pi-     ',
3155      &'n0      ','nbar0   ','p+      ','pbar-   ','gamma   ',
3156      &'lambda0 ','sigma-  ','sigma0  ','sigma+  ','xi-     ',
3157      &'xi0     ','omega-  ','pi0     ','reggeon ','pomeron '/
3158       DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
3159      &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
3160      &3312,3322,3334,111,28,29/
3161
3162 C...Store initial energy. Default frame.
3163       VINT(290)=WIN
3164       MINT(111)=0
3165
3166 C...Convert character variables to lowercase and find their length.
3167       CHCOM(1)=CHFRAM
3168       CHCOM(2)=CHBEAM
3169       CHCOM(3)=CHTARG
3170       DO 130 I=1,3
3171         LEN(I)=8
3172         DO 110 LL=8,1,-1
3173           IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
3174           DO 100 LA=1,26
3175             IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
3176      &      CHALP(1)(LA:LA)
3177   100     CONTINUE
3178   110   CONTINUE
3179         CHIDNT(I)=CHCOM(I)
3180
3181 C...Fix up bar, underscore and charge in particle name (if needed).
3182         DO 120 LL=1,6
3183           IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
3184             CHTEMP=CHIDNT(I)
3185             CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//'  '
3186           ENDIF
3187   120   CONTINUE
3188         IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba'
3189         IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
3190           CHTEMP=CHIDNT(I)
3191           CHIDNT(I)='nu_'//CHTEMP(3:7)
3192         ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
3193           CHIDNT(I)(1:3)='n0 '
3194         ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
3195           CHIDNT(I)(1:5)='nbar0'
3196         ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
3197           CHIDNT(I)(1:3)='p+ '
3198         ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
3199      &    CHIDNT(I)(1:2).EQ.'p-') THEN
3200           CHIDNT(I)(1:5)='pbar-'
3201         ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
3202           CHIDNT(I)(7:7)='0'
3203         ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
3204           CHIDNT(I)(1:7)='reggeon'
3205         ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
3206           CHIDNT(I)(1:7)='pomeron'
3207         ENDIF
3208   130 CONTINUE
3209
3210 C...Identify free initialization.
3211       IF(CHCOM(1)(1:2).EQ.'no') THEN
3212         MINT(65)=1
3213         RETURN
3214       ENDIF
3215
3216 C...Identify incoming beam and target particles.
3217       DO 150 I=1,2
3218         DO 140 J=1,29
3219           IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
3220   140   CONTINUE
3221         PM(I)=PYMASS(MINT(10+I))
3222         VINT(2+I)=PM(I)
3223   150 CONTINUE
3224       IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
3225       IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
3226       IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
3227
3228 C...Identify choice of frame and input energies.
3229       CHINIT=' '
3230
3231 C...Events defined in the CM frame.
3232       IF(CHCOM(1)(1:2).EQ.'cm') THEN
3233         MINT(111)=1
3234         S=WIN**2
3235         IF(MSTP(122).GE.1) THEN
3236           IF(CHCOM(2)(1:1).NE.'e') THEN
3237             LOFFS=(31-(LEN(2)+LEN(3)))/2
3238             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
3239      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3240      &      ' collider'//' '
3241           ELSE
3242             LOFFS=(30-(LEN(2)+LEN(3)))/2
3243             CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
3244      &      CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3245      &      ' collider'//' '
3246           ENDIF
3247           WRITE(MSTU(11),5200) CHINIT
3248           WRITE(MSTU(11),5300) WIN
3249         ENDIF
3250
3251 C...Events defined in fixed target frame.
3252       ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
3253         MINT(111)=2
3254         S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
3255         IF(MSTP(122).GE.1) THEN
3256           LOFFS=(29-(LEN(2)+LEN(3)))/2
3257           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3258      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3259      &    ' fixed target'//' '
3260           WRITE(MSTU(11),5200) CHINIT
3261           WRITE(MSTU(11),5400) WIN
3262           WRITE(MSTU(11),5500) SQRT(S)
3263         ENDIF
3264
3265 C...Frame defined by user three-vectors.
3266       ELSEIF(CHCOM(1)(1:3).EQ.'use') THEN
3267         MINT(111)=3
3268         P(1,5)=PM(1)
3269         P(2,5)=PM(2)
3270         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3271         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3272         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3273      &  (P(1,3)+P(2,3))**2
3274         IF(MSTP(122).GE.1) THEN
3275           LOFFS=(12-(LEN(2)+LEN(3)))/2
3276           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3277      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3278      &    ' user-specified configuration'//' '
3279           WRITE(MSTU(11),5200) CHINIT
3280           WRITE(MSTU(11),5600)
3281           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3282           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3283           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3284         ENDIF
3285
3286 C...Frame defined by user four-vectors.
3287       ELSEIF(CHCOM(1)(1:4).EQ.'four') THEN
3288         MINT(111)=4
3289         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3290         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3291         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3292         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3293         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3294      &  (P(1,3)+P(2,3))**2
3295         IF(MSTP(122).GE.1) THEN
3296           LOFFS=(12-(LEN(2)+LEN(3)))/2
3297           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3298      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3299      &    ' user-specified configuration'//' '
3300           WRITE(MSTU(11),5200) CHINIT
3301           WRITE(MSTU(11),5600)
3302           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3303           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3304           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3305         ENDIF
3306
3307 C...Frame defined by user five-vectors.
3308       ELSEIF(CHCOM(1)(1:4).EQ.'five') THEN
3309         MINT(111)=5
3310         S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
3311      &  (P(1,3)+P(2,3))**2
3312         IF(MSTP(122).GE.1) THEN
3313           LOFFS=(12-(LEN(2)+LEN(3)))/2
3314           CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
3315      &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
3316      &    ' user-specified configuration'//' '
3317           WRITE(MSTU(11),5200) CHINIT
3318           WRITE(MSTU(11),5600)
3319           WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
3320           WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
3321           WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
3322         ENDIF
3323
3324 C...Unknown frame. Error for too low CM energy.
3325       ELSE
3326         WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
3327         STOP
3328       ENDIF
3329       IF(S.LT.PARP(2)**2) THEN
3330         WRITE(MSTU(11),5900) SQRT(S)
3331         STOP
3332       ENDIF
3333
3334 C...Formats for initialization and error information.
3335  5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
3336      &1X,'Execution stopped!')
3337  5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
3338      &1X,'Execution stopped!')
3339  5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
3340  5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
3341      &19X,'I'/1X,'I',76X,'I'/1X,78('='))
3342  5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
3343  5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
3344      &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
3345  5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
3346      &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
3347  5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
3348  5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
3349      &1X,'Execution stopped!')
3350  5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
3351      &'generation.'/1X,'Execution stopped!')
3352
3353       RETURN
3354       END
3355
3356 C*********************************************************************
3357
3358 *$ CREATE PYINKI.FOR
3359 *COPY PYINKI
3360 C...PYINKI
3361 C...Sets up kinematics, including rotations and boosts to/from CM frame.
3362
3363       SUBROUTINE PYINKI(MODKI)
3364
3365 C...Double precision and integer declarations.
3366       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3367       INTEGER PYK,PYCHGE,PYCOMP
3368 C...Commonblocks.
3369       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3370       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3371       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3372       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3373       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3374       COMMON/PYINT1/MINT(400),VINT(400)
3375       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
3376
3377 C...Set initial flavour state.
3378       N=2
3379       DO 100 I=1,2
3380         K(I,1)=1
3381         K(I,2)=MINT(10+I)
3382   100 CONTINUE
3383
3384 C...Reset boost. Do kinematics for various cases.
3385       DO 110 J=6,10
3386         VINT(J)=0D0
3387   110 CONTINUE
3388
3389 C...Set up kinematics for events defined in CM frame.
3390       IF(MINT(111).EQ.1) THEN
3391         WIN=VINT(290)
3392         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3393         S=WIN**2
3394         P(1,5)=VINT(3)
3395         P(2,5)=VINT(4)
3396         P(1,1)=0D0
3397         P(1,2)=0D0
3398         P(2,1)=0D0
3399         P(2,2)=0D0
3400         P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
3401      &  (4D0*S))
3402         P(2,3)=-P(1,3)
3403         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3404         P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
3405
3406 C...Set up kinematics for fixed target events.
3407       ELSEIF(MINT(111).EQ.2) THEN
3408         WIN=VINT(290)
3409         IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
3410         P(1,5)=VINT(3)
3411         P(2,5)=VINT(4)
3412         P(1,1)=0D0
3413         P(1,2)=0D0
3414         P(2,1)=0D0
3415         P(2,2)=0D0
3416         P(1,3)=WIN
3417         P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
3418         P(2,3)=0D0
3419         P(2,4)=P(2,5)
3420         S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
3421         VINT(10)=P(1,3)/(P(1,4)+P(2,4))
3422         CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
3423
3424 C...Set up kinematics for events in user-defined frame.
3425       ELSEIF(MINT(111).EQ.3) THEN
3426         P(1,5)=VINT(3)
3427         P(2,5)=VINT(4)
3428         P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
3429         P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
3430         DO 120 J=1,3
3431           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3432   120   CONTINUE
3433         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3434         VINT(7)=PYANGL(P(1,1),P(1,2))
3435         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3436         VINT(6)=PYANGL(P(1,3),P(1,1))
3437         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3438         S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
3439
3440 C...Set up kinematics for events with user-defined four-vectors.
3441       ELSEIF(MINT(111).EQ.4) THEN
3442         PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
3443         P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
3444         PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
3445         P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
3446         DO 130 J=1,3
3447           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3448   130   CONTINUE
3449         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3450         VINT(7)=PYANGL(P(1,1),P(1,2))
3451         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3452         VINT(6)=PYANGL(P(1,3),P(1,1))
3453         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3454         S=(P(1,4)+P(2,4))**2
3455
3456 C...Set up kinematics for events with user-defined five-vectors.
3457       ELSEIF(MINT(111).EQ.5) THEN
3458         DO 140 J=1,3
3459           VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
3460   140   CONTINUE
3461         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
3462         VINT(7)=PYANGL(P(1,1),P(1,2))
3463         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
3464         VINT(6)=PYANGL(P(1,3),P(1,1))
3465         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
3466         S=(P(1,4)+P(2,4))**2
3467       ENDIF
3468
3469 C...Return or error for too low CM energy.
3470       IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
3471         IF(MSTP(172).LE.1) THEN
3472           CALL PYERRM(23,
3473      &    '(PYINKI:) too low invariant mass in this event')
3474         ELSE
3475           MSTI(61)=1
3476           RETURN
3477         ENDIF
3478       ENDIF
3479
3480 C...Save information on incoming particles.
3481       VINT(1)=SQRT(S)
3482       VINT(2)=S
3483       IF(MINT(111).GE.4) VINT(3)=P(1,5)
3484       IF(MINT(111).GE.4) VINT(4)=P(2,5)
3485       VINT(5)=P(1,3)
3486       IF(MODKI.EQ.0) VINT(289)=S
3487       DO 150 J=1,5
3488         V(1,J)=0D0
3489         V(2,J)=0D0
3490         VINT(290+J)=P(1,J)
3491         VINT(295+J)=P(2,J)
3492   150 CONTINUE
3493
3494 C...Store pT cut-off and related constants to be used in generation.
3495       IF(MODKI.EQ.0) VINT(285)=CKIN(3)
3496       IF(MSTP(82).LE.1) THEN
3497         IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/
3498      &  LOG(900D0/200D0)
3499         PTMN=PARP(81)
3500       ELSE
3501         IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/
3502      &  LOG(900D0/200D0)
3503         PTMN=PARP(82)
3504       ENDIF
3505       VINT(149)=4D0*PTMN**2/S
3506
3507       RETURN
3508       END
3509
3510 C*********************************************************************
3511
3512 *$ CREATE PYINPR.FOR
3513 *COPY PYINPR
3514 C...PYINPR
3515 C...Selects partonic subprocesses to be included in the simulation.
3516
3517       SUBROUTINE PYINPR
3518
3519 C...Double precision and integer declarations.
3520       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3521       INTEGER PYK,PYCHGE,PYCOMP
3522 C...Commonblocks.
3523       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3524       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
3525       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3526       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3527       COMMON/PYINT1/MINT(400),VINT(400)
3528       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3529       SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
3530
3531 C...Reset processes to be included.
3532       IF(MSEL.NE.0) THEN
3533         DO 100 I=1,500
3534           MSUB(I)=0
3535   100   CONTINUE
3536       ENDIF
3537
3538 C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.
3539       IF(MINT(121).EQ.2) THEN
3540         MSUB(10)=1
3541         MINT(123)=MINT(122)+1
3542
3543 C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.
3544 C...Here also set a few parameters otherwise normally not touched.
3545       ELSEIF(MINT(121).GT.1) THEN
3546
3547 C...Parton distributions dampened at small Q2; go to low energies,
3548 C...alpha_s <1; no minimum pT cut-off a priori.
3549         MSTP(57)=3
3550         MSTP(85)=0
3551         PARP(2)=2D0
3552         PARU(115)=1D0
3553         CKIN(5)=0.2D0
3554         CKIN(6)=0.2D0
3555
3556 C...Define pT cut-off parameters and whether run involves low-pT.
3557         IF(MSTP(82).LE.1) THEN
3558           PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3559         ELSE
3560           PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0)
3561         ENDIF
3562         PTMDIR=PARP(15)
3563         PTMANO=PTMVMD
3564         IF(MSTP(15).EQ.5) PTMANO=0.60D0+
3565      &  0.125D0*LOG(1D0+0.10D0*VINT(1))**2
3566         IPTL=1
3567         IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
3568         IF(MSEL.EQ.2) IPTL=1
3569
3570 C...Set up for p/VMD * VMD.
3571         IF(MINT(122).EQ.1) THEN
3572           MINT(123)=2
3573           MSUB(11)=1
3574           MSUB(12)=1
3575           MSUB(13)=1
3576           MSUB(28)=1
3577           MSUB(53)=1
3578           MSUB(68)=1
3579           IF(IPTL.EQ.1) MSUB(95)=1
3580           IF(MSEL.EQ.2) THEN
3581             MSUB(91)=1
3582             MSUB(92)=1
3583             MSUB(93)=1
3584             MSUB(94)=1
3585           ENDIF
3586           PARP(81)=PTMVMD
3587           PARP(82)=PTMVMD
3588           IF(IPTL.EQ.1) CKIN(3)=0D0
3589
3590 C...Set up for p/VMD * direct gamma.
3591         ELSEIF(MINT(122).EQ.2) THEN
3592           MINT(123)=0
3593           IF(MINT(121).EQ.6) MINT(123)=5
3594           MSUB(33)=1
3595           MSUB(54)=1
3596           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3597
3598 C...Set up for p/VMD * anomalous gamma.
3599         ELSEIF(MINT(122).EQ.3) THEN
3600           MINT(123)=3
3601           IF(MINT(121).EQ.6) MINT(123)=7
3602           MSUB(11)=1
3603           MSUB(12)=1
3604           MSUB(13)=1
3605           MSUB(28)=1
3606           MSUB(53)=1
3607           MSUB(68)=1
3608           IF(MSTP(82).GE.2) MSTP(85)=1
3609           IF(IPTL.EQ.1) CKIN(3)=PTMANO
3610
3611 C...Set up for direct * direct gamma (switch off leptons).
3612         ELSEIF(MINT(122).EQ.4) THEN
3613           MINT(123)=0
3614           MSUB(58)=1
3615           DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
3616             IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
3617   110     CONTINUE
3618           IF(IPTL.EQ.1) CKIN(3)=PTMDIR
3619
3620 C...Set up for direct * anomalous gamma.
3621         ELSEIF(MINT(122).EQ.5) THEN
3622           MINT(123)=6
3623           MSUB(33)=1
3624           MSUB(54)=1
3625           IF(IPTL.EQ.1) CKIN(3)=PTMANO
3626
3627 C...Set up for anomalous * anomalous gamma.
3628         ELSEIF(MINT(122).EQ.6) THEN
3629           MINT(123)=3
3630           MSUB(11)=1
3631           MSUB(12)=1
3632           MSUB(13)=1
3633           MSUB(28)=1
3634           MSUB(53)=1
3635           MSUB(68)=1
3636           IF(MSTP(82).GE.2) MSTP(85)=1
3637           IF(IPTL.EQ.1) CKIN(3)=PTMANO
3638         ENDIF
3639
3640 C...End of special set up for gamma-p and gamma-gamma.
3641         CKIN(1)=2D0*CKIN(3)
3642       ENDIF
3643
3644 C...Flavour information for individual beams.
3645       DO 120 I=1,2
3646         MINT(40+I)=1
3647         IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
3648         IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
3649         IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2
3650         MINT(44+I)=MINT(40+I)
3651         IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3
3652   120 CONTINUE
3653
3654 C...If two gammas, whereof one direct, pick the first.
3655       IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3656         IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN
3657           MINT(41)=1
3658           MINT(45)=1
3659         ENDIF
3660       ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
3661         IF(MINT(123).GE.4) CALL PYERRM(26,
3662      &  '(PYINPR:) unallowed MSTP(14) code for single photon')
3663       ENDIF
3664
3665 C...Flavour information on combination of incoming particles.
3666       MINT(43)=2*MINT(41)+MINT(42)-2
3667       MINT(44)=MINT(43)
3668       IF(MINT(123).LE.0) THEN
3669         IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
3670         IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
3671       ELSEIF(MINT(123).LE.3) THEN
3672         IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
3673         IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
3674       ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
3675         MINT(43)=4
3676         MINT(44)=1
3677       ENDIF
3678       MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
3679       IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
3680       MINT(50)=0
3681       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
3682       IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3)
3683      &MINT(50)=0
3684       MINT(107)=0
3685       IF(MINT(11).EQ.22) THEN
3686         MINT(107)=MINT(123)
3687         IF(MINT(123).GE.4) MINT(107)=0
3688         IF(MINT(123).EQ.7) MINT(107)=2
3689       ENDIF
3690       MINT(108)=0
3691       IF(MINT(12).EQ.22) THEN
3692         MINT(108)=MINT(123)
3693         IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
3694         IF(MINT(123).EQ.7) MINT(108)=3
3695       ENDIF
3696
3697 C...Select default processes according to incoming beams
3698 C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).
3699       IF(MINT(121).GT.1) THEN
3700       ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
3701
3702         IF(MINT(43).EQ.1) THEN
3703 C...Lepton + lepton -> gamma/Z0 or W.
3704           IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
3705           IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
3706
3707         ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
3708      &    (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
3709 C...Unresolved photon + lepton: Compton scattering.
3710           MSUB(34)=1
3711
3712         ELSEIF(MINT(43).LE.3) THEN
3713 C...Lepton + hadron: deep inelastic scattering.
3714           MSUB(10)=1
3715
3716         ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
3717      &    MINT(12).EQ.22) THEN
3718 C...Two unresolved photons: fermion pair production.
3719           MSUB(58)=1
3720
3721         ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
3722      &    .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
3723      &    MINT(12).EQ.22)) THEN
3724 C...Unresolved photon + hadron: photon-parton scattering.
3725           MSUB(33)=1
3726           MSUB(34)=1
3727           MSUB(54)=1
3728
3729         ELSEIF(MSEL.EQ.1) THEN
3730 C...High-pT QCD processes:
3731           MSUB(11)=1
3732           MSUB(12)=1
3733           MSUB(13)=1
3734           MSUB(28)=1
3735           MSUB(53)=1
3736           MSUB(68)=1
3737           IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1
3738           IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) MSUB(95)=1
3739           IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
3740
3741         ELSE
3742 C...All QCD processes:
3743           MSUB(11)=1
3744           MSUB(12)=1
3745           MSUB(13)=1
3746           MSUB(28)=1
3747           MSUB(53)=1
3748           MSUB(68)=1
3749           MSUB(91)=1
3750           MSUB(92)=1
3751           MSUB(93)=1
3752           MSUB(94)=1
3753           MSUB(95)=1
3754         ENDIF
3755
3756       ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
3757 C...Heavy quark production.
3758         MSUB(81)=1
3759         MSUB(82)=1
3760         MSUB(84)=1
3761         DO 130 J=1,MIN(8,MDCY(21,3))
3762           MDME(MDCY(21,2)+J-1,1)=0
3763   130   CONTINUE
3764         MDME(MDCY(21,2)+MSEL-1,1)=1
3765         MSUB(85)=1
3766         DO 140 J=1,MIN(12,MDCY(22,3))
3767           MDME(MDCY(22,2)+J-1,1)=0
3768   140   CONTINUE
3769         MDME(MDCY(22,2)+MSEL-1,1)=1
3770
3771       ELSEIF(MSEL.EQ.10) THEN
3772 C...Prompt photon production:
3773         MSUB(14)=1
3774         MSUB(18)=1
3775         MSUB(29)=1
3776
3777       ELSEIF(MSEL.EQ.11) THEN
3778 C...Z0/gamma* production:
3779         MSUB(1)=1
3780
3781       ELSEIF(MSEL.EQ.12) THEN
3782 C...W+/- production:
3783         MSUB(2)=1
3784
3785       ELSEIF(MSEL.EQ.13) THEN
3786 C...Z0 + jet:
3787         MSUB(15)=1
3788         MSUB(30)=1
3789
3790       ELSEIF(MSEL.EQ.14) THEN
3791 C...W+/- + jet:
3792         MSUB(16)=1
3793         MSUB(31)=1
3794
3795       ELSEIF(MSEL.EQ.15) THEN
3796 C...Z0 & W+/- pair production:
3797         MSUB(19)=1
3798         MSUB(20)=1
3799         MSUB(22)=1
3800         MSUB(23)=1
3801         MSUB(25)=1
3802
3803       ELSEIF(MSEL.EQ.16) THEN
3804 C...h0 production:
3805         MSUB(3)=1
3806         MSUB(102)=1
3807         MSUB(103)=1
3808         MSUB(123)=1
3809         MSUB(124)=1
3810
3811       ELSEIF(MSEL.EQ.17) THEN
3812 C...h0 & Z0 or W+/- pair production:
3813         MSUB(24)=1
3814         MSUB(26)=1
3815
3816       ELSEIF(MSEL.EQ.18) THEN
3817 C...h0 production; interesting processes in e+e-.
3818         MSUB(24)=1
3819         MSUB(103)=1
3820         MSUB(123)=1
3821         MSUB(124)=1
3822
3823       ELSEIF(MSEL.EQ.19) THEN
3824 C...h0, H0 and A0 production; interesting processes in e+e-.
3825         MSUB(24)=1
3826         MSUB(103)=1
3827         MSUB(123)=1
3828         MSUB(124)=1
3829         MSUB(153)=1
3830         MSUB(171)=1
3831         MSUB(173)=1
3832         MSUB(174)=1
3833         MSUB(158)=1
3834         MSUB(176)=1
3835         MSUB(178)=1
3836         MSUB(179)=1
3837
3838       ELSEIF(MSEL.EQ.21) THEN
3839 C...Z'0 production:
3840         MSUB(141)=1
3841
3842       ELSEIF(MSEL.EQ.22) THEN
3843 C...W'+/- production:
3844         MSUB(142)=1
3845
3846       ELSEIF(MSEL.EQ.23) THEN
3847 C...H+/- production:
3848         MSUB(143)=1
3849
3850       ELSEIF(MSEL.EQ.24) THEN
3851 C...R production:
3852         MSUB(144)=1
3853
3854       ELSEIF(MSEL.EQ.25) THEN
3855 C...LQ (leptoquark) production.
3856         MSUB(145)=1
3857         MSUB(162)=1
3858         MSUB(163)=1
3859         MSUB(164)=1
3860
3861       ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
3862 C...Production of one heavy quark (W exchange):
3863         MSUB(83)=1
3864         DO 150 J=1,MIN(8,MDCY(21,3))
3865           MDME(MDCY(21,2)+J-1,1)=0
3866   150   CONTINUE
3867         MDME(MDCY(21,2)+MSEL-31,1)=1
3868
3869 CMRENNA++Define SUSY alternatives.
3870       ELSEIF(MSEL.EQ.39) THEN
3871 C...Turn on all SUSY processes.
3872         IF(MINT(43).EQ.4) THEN
3873 C...Hadron-hadron processes.
3874           DO 160 I=201,280
3875             IF(ISET(I).GE.0) MSUB(I)=1
3876   160     CONTINUE
3877         ELSEIF(MINT(43).EQ.1) THEN
3878 C...Lepton-lepton processes: QED production of squarks.
3879           DO 170 I=201,214
3880             MSUB(I)=1
3881   170     CONTINUE
3882           MSUB(210)=0
3883           MSUB(211)=0
3884           MSUB(212)=0
3885           DO 180 I=216,228
3886             MSUB(I)=1
3887   180     CONTINUE
3888           DO 190 I=261,263
3889             MSUB(I)=1
3890   190     CONTINUE
3891           MSUB(277)=1
3892           MSUB(278)=1
3893         ENDIF
3894
3895       ELSEIF(MSEL.EQ.40) THEN
3896 C...Gluinos and squarks.
3897         IF(MINT(43).EQ.4) THEN
3898           MSUB(243)=1
3899           MSUB(244)=1
3900           MSUB(258)=1
3901           MSUB(259)=1
3902           MSUB(261)=1
3903           MSUB(262)=1
3904           MSUB(264)=1
3905           MSUB(265)=1
3906           DO 200 I=271,280
3907             MSUB(I)=1
3908   200     CONTINUE
3909         ELSEIF(MINT(43).EQ.1) THEN
3910           MSUB(277)=1
3911           MSUB(278)=1
3912         ENDIF
3913
3914       ELSEIF(MSEL.EQ.41) THEN
3915 C...Stop production.
3916         MSUB(261)=1
3917         MSUB(262)=1
3918         MSUB(263)=1
3919         IF(MINT(43).EQ.4) THEN
3920           MSUB(264)=1
3921           MSUB(265)=1
3922         ENDIF
3923
3924       ELSEIF(MSEL.EQ.42) THEN
3925 C...Slepton production.
3926         DO 210 I=201,214
3927           MSUB(I)=1
3928   210   CONTINUE
3929         IF(MINT(43).NE.4) THEN
3930           MSUB(210)=0
3931           MSUB(211)=0
3932           MSUB(212)=0
3933         ENDIF
3934
3935       ELSEIF(MSEL.EQ.43) THEN
3936 C...Neutralino/Chargino + Gluino/Squark.
3937         IF(MINT(43).EQ.4) THEN
3938           DO 220 I=237,242
3939             MSUB(I)=1
3940   220     CONTINUE
3941           DO 230 I=246,257
3942             MSUB(I)=1
3943   230     CONTINUE
3944         ENDIF
3945
3946       ELSEIF(MSEL.EQ.44) THEN
3947 C...Neutralino/Chargino pair production.
3948         IF(MINT(43).EQ.4) THEN
3949           DO 240 I=216,236
3950             MSUB(I)=1
3951   240     CONTINUE
3952         ELSEIF(MINT(43).EQ.1) THEN
3953           DO 250 I=216,228
3954             MSUB(I)=1
3955   250     CONTINUE
3956         ENDIF
3957       ENDIF
3958
3959 C...Find heaviest new quark flavour allowed in processes 81-84.
3960       KFLQM=1
3961       DO 260 I=1,MIN(8,MDCY(21,3))
3962         IDC=I+MDCY(21,2)-1
3963         IF(MDME(IDC,1).LE.0) GOTO 260
3964         KFLQM=I
3965   260 CONTINUE
3966       IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
3967      &KFLQM=MSTP(7)
3968       MINT(55)=KFLQM
3969       KFPR(81,1)=KFLQM
3970       KFPR(81,2)=KFLQM
3971       KFPR(82,1)=KFLQM
3972       KFPR(82,2)=KFLQM
3973       KFPR(83,1)=KFLQM
3974       KFPR(84,1)=KFLQM
3975       KFPR(84,2)=KFLQM
3976
3977 C...Find heaviest new fermion flavour allowed in process 85.
3978       KFLFM=1
3979       DO 270 I=1,MIN(12,MDCY(22,3))
3980         IDC=I+MDCY(22,2)-1
3981         IF(MDME(IDC,1).LE.0) GOTO 270
3982         KFLFM=KFDP(IDC,1)
3983   270 CONTINUE
3984       IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
3985      &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
3986       MINT(56)=KFLFM
3987       KFPR(85,1)=KFLFM
3988       KFPR(85,2)=KFLFM
3989
3990       RETURN
3991       END
3992
3993 C*********************************************************************
3994
3995 *$ CREATE PYXTOT.FOR
3996 *COPY PYXTOT
3997 C...PYXTOT
3998 C...Parametrizes total, elastic and diffractive cross-sections
3999 C...for different energies and beams. Donnachie-Landshoff for
4000 C...total and Schuler-Sjostrand for elastic and diffractive.
4001 C...Process code IPROC:
4002 C...=  1 : p + p;
4003 C...=  2 : pbar + p;
4004 C...=  3 : pi+ + p;
4005 C...=  4 : pi- + p;
4006 C...=  5 : pi0 + p;
4007 C...=  6 : phi + p;
4008 C...=  7 : J/psi + p;
4009 C...= 11 : rho + rho;
4010 C...= 12 : rho + phi;
4011 C...= 13 : rho + J/psi;
4012 C...= 14 : phi + phi;
4013 C...= 15 : phi + J/psi;
4014 C...= 16 : J/psi + J/psi;
4015 C...= 21 : gamma + p (DL);
4016 C...= 22 : gamma + p (VDM).
4017 C...= 23 : gamma + pi (DL);
4018 C...= 24 : gamma + pi (VDM);
4019 C...= 25 : gamma + gamma (DL);
4020 C...= 26 : gamma + gamma (VDM).
4021
4022       SUBROUTINE PYXTOT
4023
4024 C...Double precision and integer declarations.
4025       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4026       INTEGER PYK,PYCHGE,PYCOMP
4027 C...Commonblocks.
4028       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4029       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4030       COMMON/PYINT1/MINT(400),VINT(400)
4031       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4032       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4033       SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
4034 C...Local arrays.
4035       DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
4036      &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
4037      &CEFFD(10,9),SIGTMP(6,0:5)
4038
4039 C...Common constants.
4040       DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
4041      &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
4042      &FACDD/0.0084D0/
4043
4044 C...Number of multiple processes to be evaluated (= 0 : undefined).
4045       DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
4046 C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
4047       DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
4048      &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
4049      &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
4050       DATA YPAR/
4051      &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
4052      &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
4053      &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
4054
4055 C...Beam and target hadron class:
4056 C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
4057       DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
4058       DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
4059 C...Characteristic class masses, slope parameters, beta = sqrt(X).
4060       DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
4061       DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
4062       DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
4063
4064 C...Fitting constants used in parametrizations of diffractive results.
4065       DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4066       DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
4067       DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
4068      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
4069      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
4070      &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
4071      &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
4072      &0.267D0, 0.0D0, -0.46D0,  75D0, 0.267D0, 0.0D0, -0.46D0,  75D0,
4073      &0.232D0, 0.0D0, -0.46D0,  85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
4074      &0.115D0, 0.0D0, -0.50D0,  90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
4075      &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
4076      &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
4077      &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
4078       DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
4079      &3.11D0, -7.34D0,  9.71D0, 0.068D0, -0.42D0,  1.31D0,
4080      &-1.37D0,  35.0D0,  118D0,  3.11D0, -7.10D0,  10.6D0,
4081      &0.073D0, -0.41D0, 1.17D0, -1.41D0,  31.6D0,   95D0,
4082      &3.12D0, -7.43D0,  9.21D0, 0.067D0, -0.44D0,  1.41D0,
4083      &-1.35D0,  36.5D0,  132D0,  3.13D0, -8.18D0, -4.20D0,
4084      &0.056D0, -0.71D0, 3.12D0, -1.12D0,  55.2D0, 1298D0,
4085      &3.11D0, -6.90D0,  11.4D0, 0.078D0, -0.40D0,  1.05D0,
4086      &-1.40D0,  28.4D0,   78D0,  3.11D0, -7.13D0,  10.0D0,
4087      &0.071D0, -0.41D0, 1.23D0, -1.34D0,  33.1D0,  105D0,
4088      &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0,  2.72D0,
4089      &-1.13D0,  53.1D0,  995D0,  3.11D0, -7.39D0,  8.22D0,
4090      &0.065D0, -0.44D0, 1.45D0, -1.36D0,  38.1D0,  148D0,
4091      &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0,  3.32D0,
4092      &-1.12D0,  55.6D0, 1472D0,  4.18D0, -29.2D0,  56.2D0,
4093      &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
4094
4095 C...Parameters. Combinations of the energy.
4096       AEM=PARU(101)
4097       PMTH=PARP(102)
4098       S=VINT(2)
4099       SRT=VINT(1)
4100       SEPS=S**EPS
4101       SETA=S**ETA
4102       SLOG=LOG(S)
4103
4104 C...Ratio of gamma/pi (for rescaling in parton distributions).
4105       VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
4106      &(XPAR(5)*SEPS+YPAR(5)*SETA)
4107       IF(MINT(50).NE.1) RETURN
4108
4109 C...Order flavours of incoming particles: KF1 < KF2.
4110       IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
4111         KF1=IABS(MINT(11))
4112         KF2=IABS(MINT(12))
4113         IORD=1
4114       ELSE
4115         KF1=IABS(MINT(12))
4116         KF2=IABS(MINT(11))
4117         IORD=2
4118       ENDIF
4119       ISGN12=ISIGN(1,MINT(11)*MINT(12))
4120
4121 C...Find process number (for lookup tables).
4122       IF(KF1.GT.1000) THEN
4123         IPROC=1
4124         IF(ISGN12.LT.0) IPROC=2
4125       ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
4126         IPROC=3
4127         IF(ISGN12.LT.0) IPROC=4
4128         IF(KF1.EQ.111) IPROC=5
4129       ELSEIF(KF1.GT.100) THEN
4130         IPROC=11
4131       ELSEIF(KF2.GT.1000) THEN
4132         IPROC=21
4133         IF(MINT(123).EQ.2) IPROC=22
4134       ELSEIF(KF2.GT.100) THEN
4135         IPROC=23
4136         IF(MINT(123).EQ.2) IPROC=24
4137       ELSE
4138         IPROC=25
4139         IF(MINT(123).EQ.2) IPROC=26
4140       ENDIF
4141
4142 C... Number of multiple processes to be stored; beam/target side.
4143       NPR=NPROC(IPROC)
4144       MINT(101)=1
4145       MINT(102)=1
4146       IF(NPR.EQ.3) THEN
4147         MINT(100+IORD)=4
4148       ELSEIF(NPR.EQ.6) THEN
4149         MINT(101)=4
4150         MINT(102)=4
4151       ENDIF
4152       N1=0
4153       IF(MINT(101).EQ.4) N1=4
4154       N2=0
4155       IF(MINT(102).EQ.4) N2=4
4156
4157 C...Do not do any more for user-set or undefined cross-sections.
4158       IF(MSTP(31).LE.0) RETURN
4159       IF(NPR.EQ.0) CALL PYERRM(26,
4160      &'(PYXTOT:) cross section for this process not yet implemented')
4161
4162 C...Parameters. Combinations of the energy.
4163       AEM=PARU(101)
4164       PMTH=PARP(102)
4165       S=VINT(2)
4166       SRT=VINT(1)
4167       SEPS=S**EPS
4168       SETA=S**ETA
4169       SLOG=LOG(S)
4170
4171 C...Loop over multiple processes (for VDM).
4172       DO 110 I=1,NPR
4173         IF(NPR.EQ.1) THEN
4174           IPR=IPROC
4175         ELSEIF(NPR.EQ.3) THEN
4176           IPR=I+4
4177           IF(KF2.LT.1000) IPR=I+10
4178         ELSEIF(NPR.EQ.6) THEN
4179           IPR=I+10
4180         ENDIF
4181
4182 C...Evaluate hadron species, mass, slope contribution and fit number.
4183         IHA=IHADA(IPR)
4184         IHB=IHADB(IPR)
4185         PMA=PMHAD(IHA)
4186         PMB=PMHAD(IHB)
4187         BHA=BHAD(IHA)
4188         BHB=BHAD(IHB)
4189         ISD=IFITSD(IPR)
4190         IDD=IFITDD(IPR)
4191
4192 C...Skip if energy too low relative to masses.
4193         DO 100 J=0,5
4194           SIGTMP(I,J)=0D0
4195   100   CONTINUE
4196         IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
4197
4198 C...Total cross-section. Elastic slope parameter and cross-section.
4199         SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
4200         BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
4201         SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
4202
4203 C...Diffractive scattering A + B -> X + B.
4204         BSD=2D0*BHB
4205         SQML=(PMA+PMTH)**2
4206         SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
4207         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4208      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4209         BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
4210         SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
4211      &  (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
4212         SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
4213
4214 C...Diffractive scattering A + B -> A + X.
4215         BSD=2D0*BHA
4216         SQML=(PMB+PMTH)**2
4217         SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
4218         SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
4219      &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
4220         BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
4221         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
4222      &  (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
4223         SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
4224
4225 C...Order single diffractive correctly.
4226         IF(IORD.EQ.2) THEN
4227           SIGSAV=SIGTMP(I,2)
4228           SIGTMP(I,2)=SIGTMP(I,3)
4229           SIGTMP(I,3)=SIGSAV
4230         ENDIF
4231
4232 C...Double diffractive scattering A + B -> X1 + X2.
4233         YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
4234         DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
4235         SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
4236         IF(YEFF.LE.0) SUM1=0D0
4237         SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
4238         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
4239         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
4240         SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
4241      &  (2D0*ALP)
4242         SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
4243         SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
4244         SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
4245      &  (2D0*ALP)
4246         BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
4247         SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
4248         SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
4249      &  LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
4250         SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
4251
4252 C...Non-diffractive by unitarity.
4253         SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
4254      &  SIGTMP(I,4)
4255   110 CONTINUE
4256
4257 C...Put temporary results in output array: only one process.
4258       IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
4259         DO 120 J=0,5
4260           SIGT(0,0,J)=SIGTMP(1,J)
4261   120   CONTINUE
4262
4263 C...Beam multiple processes.
4264       ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
4265         DO 140 I=1,4
4266           CONV=AEM/PARP(160+I)
4267           I1=MAX(1,I-1)
4268           DO 130 J=0,5
4269             SIGT(I,0,J)=CONV*SIGTMP(I1,J)
4270   130     CONTINUE
4271   140   CONTINUE
4272         DO 150 J=0,5
4273           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4274   150   CONTINUE
4275
4276 C...Target multiple processes.
4277       ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
4278         DO 170 I=1,4
4279           CONV=AEM/PARP(160+I)
4280           IV=MAX(1,I-1)
4281           DO 160 J=0,5
4282             SIGT(0,I,J)=CONV*SIGTMP(IV,J)
4283   160     CONTINUE
4284   170   CONTINUE
4285         DO 180 J=0,5
4286           SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
4287   180   CONTINUE
4288
4289 C...Both beam and target multiple processes.
4290       ELSE
4291         DO 210 I1=1,4
4292           DO 200 I2=1,4
4293             CONV=AEM**2/(PARP(160+I1)*PARP(160+I2))
4294             IF(I1.LE.2) THEN
4295               IV=MAX(1,I2-1)
4296             ELSEIF(I2.LE.2) THEN
4297               IV=MAX(1,I1-1)
4298             ELSEIF(I1.EQ.I2) THEN
4299               IV=2*I1-2
4300             ELSE
4301               IV=5
4302             ENDIF
4303             DO 190 J=0,5
4304               JV=J
4305               IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
4306               SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
4307   190       CONTINUE
4308   200     CONTINUE
4309   210   CONTINUE
4310         DO 230 J=0,5
4311           DO 220 I=1,4
4312             SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
4313             SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
4314   220     CONTINUE
4315           SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
4316   230   CONTINUE
4317       ENDIF
4318
4319 C...Scale up uniformly for Donnachie-Landshoff parametrization.
4320       IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
4321         RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
4322         DO 260 I1=0,N1
4323           DO 250 I2=0,N2
4324             DO 240 J=0,5
4325               SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
4326   240       CONTINUE
4327   250     CONTINUE
4328   260   CONTINUE
4329       ENDIF
4330
4331       RETURN
4332       END
4333
4334 C*********************************************************************
4335
4336 *$ CREATE PYMAXI.FOR
4337 *COPY PYMAXI
4338 C...PYMAXI
4339 C...Finds optimal set of coefficients for kinematical variable selection
4340 C...and the maximum of the part of the differential cross-section used
4341 C...in the event weighting.
4342
4343       SUBROUTINE PYMAXI
4344
4345 C...Double precision and integer declarations.
4346       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4347       INTEGER PYK,PYCHGE,PYCOMP
4348 C...Parameter statement to help give large particle numbers.
4349       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
4350 C...Commonblocks.
4351       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4352       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4353       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
4354       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4355       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4356       COMMON/PYINT1/MINT(400),VINT(400)
4357       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4358       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
4359       COMMON/PYINT4/MWID(500),WIDS(500,5)
4360       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4361       COMMON/PYINT6/PROC(0:500)
4362       CHARACTER PROC*28
4363       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
4364       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4365      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
4366 C...Local arrays, character variables and data.
4367       CHARACTER CVAR(4)*4
4368       DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
4369      &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
4370      &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
4371       DATA CVAR/'tau ','tau''','y*  ','cth '/
4372       DATA SIGSSM/3*0D0/
4373
4374 C...Select subprocess to study: skip cases not applicable.
4375       NPOSI=0
4376       VINT(143)=1D0
4377       VINT(144)=1D0
4378       XSEC(0,1)=0D0
4379       DO 460 ISUB=1,500
4380         MINT(51)=0
4381         IF(ISET(ISUB).EQ.11) THEN
4382           XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
4383           NPOSI=NPOSI+1
4384           GOTO 450
4385         ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
4386           XSEC(ISUB,1)=SIGT(0,0,ISUB-90)
4387           IF(MSUB(ISUB).NE.1) GOTO 460
4388           NPOSI=NPOSI+1
4389           GOTO 450
4390         ELSEIF(ISUB.EQ.96) THEN
4391           IF(MINT(50).EQ.0) GOTO 460
4392           IF(MSUB(95).NE.1.AND.MSTP(81).LE.0.AND.MSTP(131).LE.0)
4393      &    GOTO 460
4394           IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
4395         ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
4396      &    ISUB.EQ.53.OR.ISUB.EQ.68) THEN
4397           IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
4398         ELSE
4399           IF(MSUB(ISUB).NE.1) GOTO 460
4400         ENDIF
4401         MINT(1)=ISUB
4402         ISTSB=ISET(ISUB)
4403         IF(ISUB.EQ.96) ISTSB=2
4404         IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
4405         MWTXS=0
4406         IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
4407      &  MSUB(94)+MSUB(95).EQ.0) MWTXS=1
4408
4409 C...Find resonances (explicit or implicit in cross-section).
4410         MINT(72)=0
4411         KFR1=0
4412         IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
4413           KFR1=KFPR(ISUB,1)
4414         ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
4415      &    .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
4416           KFR1=23
4417         ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
4418      &    .OR.ISUB.EQ.177) THEN
4419           KFR1=24
4420         ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
4421           KFR1=25
4422           IF(MSTP(46).EQ.5) THEN
4423             KFR1=30
4424             PMAS(30,1)=PARP(45)
4425             PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
4426           ENDIF
4427         ELSEIF(ISUB.EQ.194) THEN
4428           KFR1=54
4429         ENDIF
4430         CKMX=CKIN(2)
4431         IF(CKMX.LE.0D0) CKMX=VINT(1)
4432         KCR1=PYCOMP(KFR1)
4433         IF(KFR1.NE.0) THEN
4434           IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
4435      &    CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
4436         ENDIF
4437         IF(KFR1.NE.0) THEN
4438           TAUR1=PMAS(KCR1,1)**2/VINT(2)
4439           GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
4440           MINT(72)=1
4441           MINT(73)=KFR1
4442           VINT(73)=TAUR1
4443           VINT(74)=GAMR1
4444         ENDIF
4445         KFR2=0
4446         IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
4447           KFR2=23
4448           IF(ISUB.EQ.194) KFR2=56
4449           KCR2=PYCOMP(KFR2)
4450           TAUR2=PMAS(KCR2,1)**2/VINT(2)
4451           GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
4452           IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
4453      &    CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
4454           IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
4455             MINT(72)=2
4456             MINT(74)=KFR2
4457             VINT(75)=TAUR2
4458             VINT(76)=GAMR2
4459           ELSEIF(KFR2.NE.0) THEN
4460             KFR1=KFR2
4461             TAUR1=TAUR2
4462             GAMR1=GAMR2
4463             MINT(72)=1
4464             MINT(73)=KFR1
4465             VINT(73)=TAUR1
4466             VINT(74)=GAMR1
4467             KFR2=0
4468           ENDIF
4469         ENDIF
4470
4471 C...Find product masses and minimum pT of process.
4472         SQM3=0D0
4473         SQM4=0D0
4474         MINT(71)=0
4475         VINT(71)=CKIN(3)
4476         VINT(80)=1D0
4477         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4478           NBW=0
4479           DO 110 I=1,2
4480             PMMN(I)=0D0
4481             IF(KFPR(ISUB,I).EQ.0) THEN
4482             ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
4483      &        PARP(41)) THEN
4484               IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4485               IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
4486             ELSE
4487               NBW=NBW+1
4488 C...This prevents SUSY/t particles from becoming too light.
4489               KFLW=KFPR(ISUB,I)
4490               IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
4491                 KCW=PYCOMP(KFLW)
4492                 PMMN(I)=PMAS(KCW,1)
4493                 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
4494                   IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
4495                     PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
4496      &              PMAS(PYCOMP(KFDP(IDC,2)),1)
4497                     IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
4498      &              PMAS(PYCOMP(KFDP(IDC,3)),1)
4499                     PMMN(I)=MIN(PMMN(I),PMSUM)
4500                   ENDIF
4501   100           CONTINUE
4502               ELSEIF(KFLW.EQ.6) THEN
4503                 PMMN(I)=PMAS(24,1)+PMAS(5,1)
4504               ENDIF
4505             ENDIF
4506   110     CONTINUE
4507           IF(NBW.GE.1) THEN
4508             CKIN41=CKIN(41)
4509             CKIN43=CKIN(43)
4510             CKIN(41)=MAX(PMMN(1),CKIN(41))
4511             CKIN(43)=MAX(PMMN(2),CKIN(43))
4512             CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
4513             CKIN(41)=CKIN41
4514             CKIN(43)=CKIN43
4515             IF(MINT(51).EQ.1) THEN
4516               WRITE(MSTU(11),5100) ISUB
4517               MSUB(ISUB)=0
4518               GOTO 460
4519             ENDIF
4520             SQM3=PQM3**2
4521             SQM4=PQM4**2
4522           ENDIF
4523           IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
4524           IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
4525           IF(ISUB.EQ.96.AND.MSTP(82).LE.1) VINT(71)=PARP(81)
4526           IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82)
4527         ENDIF
4528         VINT(63)=SQM3
4529         VINT(64)=SQM4
4530
4531 C...Prepare for additional variable choices in 2 -> 3.
4532         IF(ISTSB.EQ.5) THEN
4533           VINT(201)=0D0
4534           IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
4535           VINT(206)=VINT(201)
4536           VINT(204)=PMAS(23,1)
4537           IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
4538           IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
4539      &    .OR.ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
4540           VINT(209)=VINT(204)
4541         ENDIF
4542
4543 C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
4544         NPTS(1)=2+2*MINT(72)
4545         IF(MINT(47).EQ.1) THEN
4546           IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
4547         ELSEIF(MINT(47).EQ.5) THEN
4548           IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
4549         ENDIF
4550         NPTS(2)=1
4551         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
4552           IF(MINT(47).GE.2) NPTS(2)=2
4553           IF(MINT(47).EQ.5) NPTS(2)=3
4554         ENDIF
4555         NPTS(3)=1
4556         IF(MINT(47).GE.4) NPTS(3)=3
4557         IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
4558         IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
4559         NPTS(4)=1
4560         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
4561         NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
4562
4563 C...Reset coefficients of cross-section weighting.
4564         DO 120 J=1,20
4565           COEF(ISUB,J)=0D0
4566   120   CONTINUE
4567         COEF(ISUB,1)=1D0
4568         COEF(ISUB,8)=0.5D0
4569         COEF(ISUB,9)=0.5D0
4570         COEF(ISUB,13)=1D0
4571         COEF(ISUB,18)=1D0
4572         MCTH=0
4573         MTAUP=0
4574         METAUP=0
4575         VINT(23)=0D0
4576         VINT(26)=0D0
4577         SIGSAM=0D0
4578
4579 C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
4580 C...in grid of phase space points.
4581         CALL PYKLIM(1)
4582         METAU=MINT(51)
4583         NACC=0
4584         DO 150 ITRY=1,NTRY
4585           MINT(51)=0
4586           IF(METAU.EQ.1) GOTO 150
4587           IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
4588             MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
4589             IF(MTAU.GT.2+2*MINT(72)) MTAU=7
4590             RTAU=0.5D0
4591 C...Special case when both resonances have same mass,
4592 C...as is often the case in process 194.
4593             IF(MINT(72).EQ.2) THEN
4594               IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
4595      &        0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
4596                 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
4597                   RTAU=0.4D0
4598                 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
4599                   RTAU=0.6D0
4600                 ENDIF
4601               ENDIF
4602             ENDIF
4603             CALL PYKMAP(1,MTAU,RTAU)
4604             IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
4605             METAUP=MINT(51)
4606           ENDIF
4607           IF(METAUP.EQ.1) GOTO 150
4608           IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
4609      &    .EQ.0) THEN
4610             MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
4611             CALL PYKMAP(4,MTAUP,0.5D0)
4612           ENDIF
4613           IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
4614             CALL PYKLIM(2)
4615             MEYST=MINT(51)
4616           ENDIF
4617           IF(MEYST.EQ.1) GOTO 150
4618           IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
4619             MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
4620             IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
4621             CALL PYKMAP(2,MYST,0.5D0)
4622             CALL PYKLIM(3)
4623             MECTH=MINT(51)
4624           ENDIF
4625           IF(MECTH.EQ.1) GOTO 150
4626           IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
4627             MCTH=1+MOD(ITRY-1,NPTS(4))
4628             CALL PYKMAP(3,MCTH,0.5D0)
4629           ENDIF
4630           IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
4631
4632 C...Store position and limits.
4633           MINT(51)=0
4634           CALL PYKLIM(0)
4635           IF(MINT(51).EQ.1) GOTO 150
4636           NACC=NACC+1
4637           MVARPT(NACC,1)=MTAU
4638           MVARPT(NACC,2)=MTAUP
4639           MVARPT(NACC,3)=MYST
4640           MVARPT(NACC,4)=MCTH
4641           DO 130 J=1,30
4642             VINTPT(NACC,J)=VINT(10+J)
4643   130     CONTINUE
4644
4645 C...Normal case: calculate cross-section.
4646           IF(ISTSB.NE.5) THEN
4647             CALL PYSIGH(NCHN,SIGS)
4648             IF(MWTXS.EQ.1) THEN
4649               CALL PYEVWT(WTXS)
4650               SIGS=WTXS*SIGS
4651             ENDIF
4652
4653 C..2 -> 3: find highest value out of a number of tries.
4654           ELSE
4655             SIGS=0D0
4656             DO 140 IKIN3=1,MSTP(129)
4657               CALL PYKMAP(5,0,0D0)
4658               IF(MINT(51).EQ.1) GOTO 140
4659               CALL PYSIGH(NCHN,SIGTMP)
4660               IF(MWTXS.EQ.1) THEN
4661                 CALL PYEVWT(WTXS)
4662                 SIGTMP=WTXS*SIGTMP
4663               ENDIF
4664               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4665   140       CONTINUE
4666           ENDIF
4667
4668 C...Store cross-section.
4669           SIGSPT(NACC)=SIGS
4670           IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
4671           IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
4672      &    VINT(21),VINT(22),VINT(23),VINT(26),SIGS
4673   150   CONTINUE
4674         IF(NACC.EQ.0) THEN
4675           WRITE(MSTU(11),5100) ISUB
4676           MSUB(ISUB)=0
4677           GOTO 460
4678         ELSEIF(SIGSAM.EQ.0D0) THEN
4679           WRITE(MSTU(11),5300) ISUB
4680           MSUB(ISUB)=0
4681           GOTO 460
4682         ENDIF
4683         IF(ISUB.NE.96) NPOSI=NPOSI+1
4684
4685 C...Calculate integrals in tau over maximal phase space limits.
4686         TAUMIN=VINT(11)
4687         TAUMAX=VINT(31)
4688         ATAU1=LOG(TAUMAX/TAUMIN)
4689         IF(NPTS(1).GE.2) THEN
4690           ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
4691         ENDIF
4692         IF(NPTS(1).GE.4) THEN
4693           ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
4694           ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
4695      &    GAMR1
4696         ENDIF
4697         IF(NPTS(1).GE.6) THEN
4698           ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
4699           ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
4700      &    GAMR2
4701         ENDIF
4702         IF(NPTS(1).GT.2+2*MINT(72)) THEN
4703           ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
4704         ENDIF
4705
4706 C...Reset. Sum up cross-sections in points calculated.
4707         DO 320 IVAR=1,4
4708           IF(NPTS(IVAR).EQ.1) GOTO 320
4709           IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
4710           NBIN=NPTS(IVAR)
4711           DO 170 J1=1,NBIN
4712             NAREL(J1)=0
4713             WTREL(J1)=0D0
4714             COEFU(J1)=0D0
4715             DO 160 J2=1,NBIN
4716               WTMAT(J1,J2)=0D0
4717   160       CONTINUE
4718   170     CONTINUE
4719           DO 180 IACC=1,NACC
4720             IBIN=MVARPT(IACC,IVAR)
4721             IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
4722             IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
4723             NAREL(IBIN)=NAREL(IBIN)+1
4724             WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
4725
4726 C...Sum up tau cross-section pieces in points used.
4727             IF(IVAR.EQ.1) THEN
4728               TAU=VINTPT(IACC,11)
4729               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4730               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
4731               IF(NBIN.GE.4) THEN
4732                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
4733                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
4734      &          ((TAU-TAUR1)**2+GAMR1**2)
4735               ENDIF
4736               IF(NBIN.GE.6) THEN
4737                 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
4738                 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
4739      &          ((TAU-TAUR2)**2+GAMR2**2)
4740               ENDIF
4741               IF(NBIN.GT.2+2*MINT(72)) THEN
4742                 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
4743      &          TAU/MAX(2D-6,1D0-TAU)
4744               ENDIF
4745
4746 C...Sum up tau' cross-section pieces in points used.
4747             ELSEIF(IVAR.EQ.2) THEN
4748               TAU=VINTPT(IACC,11)
4749               TAUP=VINTPT(IACC,16)
4750               TAUPMN=VINTPT(IACC,6)
4751               TAUPMX=VINTPT(IACC,26)
4752               ATAUP1=LOG(TAUPMX/TAUPMN)
4753               ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
4754               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4755               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
4756      &        (1D0-TAU/TAUP)**3/TAUP
4757               IF(NBIN.GE.3) THEN
4758                 ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
4759                 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
4760      &          TAUP/MAX(2D-6,1D0-TAUP)
4761               ENDIF
4762
4763 C...Sum up y* cross-section pieces in points used.
4764             ELSEIF(IVAR.EQ.3) THEN
4765               YST=VINTPT(IACC,12)
4766               YSTMIN=VINTPT(IACC,2)
4767               YSTMAX=VINTPT(IACC,22)
4768               AYST0=YSTMAX-YSTMIN
4769               AYST1=0.5D0*(YSTMAX-YSTMIN)**2
4770               AYST2=AYST1
4771               AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
4772               WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
4773               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
4774               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
4775               IF(MINT(45).EQ.3) THEN
4776                 TAUE=VINTPT(IACC,11)
4777                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4778                 YST0=-0.5D0*LOG(TAUE)
4779                 AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
4780      &          MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
4781                 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
4782      &          MAX(1D-6,1D0-EXP(YST-YST0))
4783               ENDIF
4784               IF(MINT(46).EQ.3) THEN
4785                 TAUE=VINTPT(IACC,11)
4786                 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
4787                 YST0=-0.5D0*LOG(TAUE)
4788                 AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
4789      &          MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
4790                 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
4791      &          MAX(1D-6,1D0-EXP(-YST-YST0))
4792               ENDIF
4793
4794 C...Sum up cos(theta-hat) cross-section pieces in points used.
4795             ELSE
4796               RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
4797               RSQM=1D0+RM34
4798               CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
4799               CTHMIN=-CTHMAX
4800               IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
4801      &        (TAUMAX*VINT(2)))
4802               ACTH1=CTHMAX-CTHMIN
4803               ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
4804               ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
4805               ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
4806               ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
4807               CTH=VINTPT(IACC,13)
4808               WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
4809               WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
4810      &        MAX(RM34,RSQM-CTH)
4811               WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
4812      &        MAX(RM34,RSQM+CTH)
4813               WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
4814      &        MAX(RM34,RSQM-CTH)**2
4815               WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
4816      &        MAX(RM34,RSQM+CTH)**2
4817             ENDIF
4818   180     CONTINUE
4819
4820 C...Check that equation system solvable.
4821           IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
4822           MSOLV=1
4823           WTRELS=0D0
4824           DO 190 IBIN=1,NBIN
4825             IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
4826      &      IRED=1,NBIN),WTREL(IBIN)
4827             IF(NAREL(IBIN).EQ.0) MSOLV=0
4828             WTRELS=WTRELS+WTREL(IBIN)
4829   190     CONTINUE
4830           IF(ABS(WTRELS).LT.1D-20) MSOLV=0
4831
4832 C...Solve to find relative importance of cross-section pieces.
4833           IF(MSOLV.EQ.1) THEN
4834             DO 200 IBIN=1,NBIN
4835               WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
4836   200       CONTINUE
4837             DO 230 IRED=1,NBIN-1
4838               DO 220 IBIN=IRED+1,NBIN
4839                 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
4840                   MSOLV=0
4841                   GOTO 260
4842                 ENDIF
4843                 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
4844                 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
4845                 DO 210 ICOE=IRED,NBIN
4846                   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
4847   210           CONTINUE
4848   220         CONTINUE
4849   230       CONTINUE
4850             DO 250 IRED=NBIN,1,-1
4851               DO 240 ICOE=IRED+1,NBIN
4852                 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
4853   240         CONTINUE
4854               COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
4855   250       CONTINUE
4856           ENDIF
4857
4858 C...Share evenly if failure.
4859   260     IF(MSOLV.EQ.0) THEN
4860             DO 270 IBIN=1,NBIN
4861               COEFU(IBIN)=1D0
4862               WTRELN(IBIN)=0.1D0
4863               IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
4864      &        WTREL(IBIN)/WTRELS)
4865   270       CONTINUE
4866           ENDIF
4867
4868 C...Normalize coefficients, with piece shared democratically.
4869           COEFSU=0D0
4870           WTRELS=0D0
4871           DO 280 IBIN=1,NBIN
4872             COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
4873             COEFSU=COEFSU+COEFU(IBIN)
4874             WTRELS=WTRELS+WTRELN(IBIN)
4875   280     CONTINUE
4876           IF(COEFSU.GT.0D0) THEN
4877             DO 290 IBIN=1,NBIN
4878               COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
4879      &        (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
4880   290       CONTINUE
4881           ELSE
4882             DO 300 IBIN=1,NBIN
4883               COEFO(IBIN)=1D0/NBIN
4884   300       CONTINUE
4885           ENDIF
4886           IF(IVAR.EQ.1) IOFF=0
4887           IF(IVAR.EQ.2) IOFF=17
4888           IF(IVAR.EQ.3) IOFF=7
4889           IF(IVAR.EQ.4) IOFF=12
4890           DO 310 IBIN=1,NBIN
4891             ICOF=IOFF+IBIN
4892             IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
4893             IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
4894             COEF(ISUB,ICOF)=COEFO(IBIN)
4895   310     CONTINUE
4896           IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
4897      &    (COEFO(IBIN),IBIN=1,NBIN)
4898   320   CONTINUE
4899
4900 C...Find two most promising maxima among points previously determined.
4901         DO 330 J=1,4
4902           IACCMX(J)=0
4903           SIGSMX(J)=0D0
4904   330   CONTINUE
4905         NMAX=0
4906         DO 390 IACC=1,NACC
4907           DO 340 J=1,30
4908             VINT(10+J)=VINTPT(IACC,J)
4909   340     CONTINUE
4910           IF(ISTSB.NE.5) THEN
4911             CALL PYSIGH(NCHN,SIGS)
4912             IF(MWTXS.EQ.1) THEN
4913               CALL PYEVWT(WTXS)
4914               SIGS=WTXS*SIGS
4915             ENDIF
4916           ELSE
4917             SIGS=0D0
4918             DO 350 IKIN3=1,MSTP(129)
4919               CALL PYKMAP(5,0,0D0)
4920               IF(MINT(51).EQ.1) GOTO 350
4921               CALL PYSIGH(NCHN,SIGTMP)
4922               IF(MWTXS.EQ.1) THEN
4923                 CALL PYEVWT(WTXS)
4924                 SIGTMP=WTXS*SIGTMP
4925               ENDIF
4926               IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
4927   350       CONTINUE
4928           ENDIF
4929           IEQ=0
4930           DO 360 IMV=1,NMAX
4931             IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
4932   360     CONTINUE
4933           IF(IEQ.EQ.0) THEN
4934             DO 370 IMV=NMAX,1,-1
4935               IIN=IMV+1
4936               IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
4937               IACCMX(IMV+1)=IACCMX(IMV)
4938               SIGSMX(IMV+1)=SIGSMX(IMV)
4939   370       CONTINUE
4940             IIN=1
4941   380       IACCMX(IIN)=IACC
4942             SIGSMX(IIN)=SIGS
4943             IF(NMAX.LE.1) NMAX=NMAX+1
4944           ENDIF
4945   390   CONTINUE
4946
4947 C...Read out starting position for search.
4948         IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
4949         SIGSAM=SIGSMX(1)
4950         DO 440 IMAX=1,NMAX
4951           IACC=IACCMX(IMAX)
4952           MTAU=MVARPT(IACC,1)
4953           MTAUP=MVARPT(IACC,2)
4954           MYST=MVARPT(IACC,3)
4955           MCTH=MVARPT(IACC,4)
4956           VTAU=0.5D0
4957           VYST=0.5D0
4958           VCTH=0.5D0
4959           VTAUP=0.5D0
4960
4961 C...Starting point and step size in parameter space.
4962           DO 430 IRPT=1,2
4963             DO 420 IVAR=1,4
4964               IF(NPTS(IVAR).EQ.1) GOTO 420
4965               IF(IVAR.EQ.1) VVAR=VTAU
4966               IF(IVAR.EQ.2) VVAR=VTAUP
4967               IF(IVAR.EQ.3) VVAR=VYST
4968               IF(IVAR.EQ.4) VVAR=VCTH
4969               IF(IVAR.EQ.1) MVAR=MTAU
4970               IF(IVAR.EQ.2) MVAR=MTAUP
4971               IF(IVAR.EQ.3) MVAR=MYST
4972               IF(IVAR.EQ.4) MVAR=MCTH
4973               IF(IRPT.EQ.1) VDEL=0.1D0
4974               IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
4975      &        0.98D0-VVAR))
4976               IF(IRPT.EQ.1) VMAR=0.02D0
4977               IF(IRPT.EQ.2) VMAR=0.002D0
4978               IMOV0=1
4979               IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
4980               DO 410 IMOV=IMOV0,8
4981
4982 C...Define new point in parameter space.
4983                 IF(IMOV.EQ.0) THEN
4984                   INEW=2
4985                   VNEW=VVAR
4986                 ELSEIF(IMOV.EQ.1) THEN
4987                   INEW=3
4988                   VNEW=VVAR+VDEL
4989                 ELSEIF(IMOV.EQ.2) THEN
4990                   INEW=1
4991                   VNEW=VVAR-VDEL
4992                 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
4993      &            VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
4994                   VVAR=VVAR+VDEL
4995                   SIGSSM(1)=SIGSSM(2)
4996                   SIGSSM(2)=SIGSSM(3)
4997                   INEW=3
4998                   VNEW=VVAR+VDEL
4999                 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
5000      &            VVAR-2D0*VDEL.GT.VMAR) THEN
5001                   VVAR=VVAR-VDEL
5002                   SIGSSM(3)=SIGSSM(2)
5003                   SIGSSM(2)=SIGSSM(1)
5004                   INEW=1
5005                   VNEW=VVAR-VDEL
5006                 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
5007                   VDEL=0.5D0*VDEL
5008                   VVAR=VVAR+VDEL
5009                   SIGSSM(1)=SIGSSM(2)
5010                   INEW=2
5011                   VNEW=VVAR
5012                 ELSE
5013                   VDEL=0.5D0*VDEL
5014                   VVAR=VVAR-VDEL
5015                   SIGSSM(3)=SIGSSM(2)
5016                   INEW=2
5017                   VNEW=VVAR
5018                 ENDIF
5019
5020 C...Convert to relevant variables and find derived new limits.
5021                 ILERR=0
5022                 IF(IVAR.EQ.1) THEN
5023                   VTAU=VNEW
5024                   CALL PYKMAP(1,MTAU,VTAU)
5025                   IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5026                     CALL PYKLIM(4)
5027                     IF(MINT(51).EQ.1) ILERR=1
5028                   ENDIF
5029                 ENDIF
5030                 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
5031      &          ILERR.EQ.0) THEN
5032                   IF(IVAR.EQ.2) VTAUP=VNEW
5033                   CALL PYKMAP(4,MTAUP,VTAUP)
5034                 ENDIF
5035                 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
5036                   CALL PYKLIM(2)
5037                   IF(MINT(51).EQ.1) ILERR=1
5038                 ENDIF
5039                 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
5040                   IF(IVAR.EQ.3) VYST=VNEW
5041                   CALL PYKMAP(2,MYST,VYST)
5042                   CALL PYKLIM(3)
5043                   IF(MINT(51).EQ.1) ILERR=1
5044                 ENDIF
5045                 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
5046      &          ILERR.EQ.0) THEN
5047                   IF(IVAR.EQ.4) VCTH=VNEW
5048                   CALL PYKMAP(3,MCTH,VCTH)
5049                 ENDIF
5050                 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
5051
5052 C...Evaluate cross-section. Save new maximum. Final maximum.
5053                 IF(ILERR.NE.0) THEN
5054                    SIGS=0.
5055                 ELSEIF(ISTSB.NE.5) THEN
5056                   CALL PYSIGH(NCHN,SIGS)
5057                   IF(MWTXS.EQ.1) THEN
5058                     CALL PYEVWT(WTXS)
5059                     SIGS=WTXS*SIGS
5060                   ENDIF
5061                 ELSE
5062                   SIGS=0D0
5063                   DO 400 IKIN3=1,MSTP(129)
5064                     CALL PYKMAP(5,0,0D0)
5065                     IF(MINT(51).EQ.1) GOTO 400
5066                     CALL PYSIGH(NCHN,SIGTMP)
5067                     IF(MWTXS.EQ.1) THEN
5068                         CALL PYEVWT(WTXS)
5069                         SIGTMP=WTXS*SIGTMP
5070                     ENDIF
5071                     IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
5072   400             CONTINUE
5073                 ENDIF
5074                 SIGSSM(INEW)=SIGS
5075                 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
5076                 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
5077      &          IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
5078   410         CONTINUE
5079   420       CONTINUE
5080   430     CONTINUE
5081   440   CONTINUE
5082         IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
5083         XSEC(ISUB,1)=1.05D0*SIGSAM
5084   450   CONTINUE
5085         IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
5086      &  PARP(174)*XSEC(ISUB,1)
5087         IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
5088   460 CONTINUE
5089       MINT(51)=0
5090
5091 C...Print summary table.
5092       IF(NPOSI.EQ.0) THEN
5093         WRITE(MSTU(11),5900)
5094         STOP
5095       ENDIF
5096       IF(MSTP(122).GE.1) THEN
5097         WRITE(MSTU(11),6000)
5098         WRITE(MSTU(11),6100)
5099         DO 470 ISUB=1,500
5100           IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
5101           IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
5102           IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MSTP(81).LE.0) GOTO 470
5103           IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
5104           IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
5105      &    .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
5106           WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
5107   470   CONTINUE
5108         WRITE(MSTU(11),6300)
5109       ENDIF
5110
5111 C...Format statements for maximization results.
5112  5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
5113      &'subprocess no',I4/1X,'Coefficient modes     tau',10X,'y*',9X,
5114      &'cth',9X,'tau''',7X,'sigma')
5115  5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
5116      &'phase space.'/1X,'Process switched off!')
5117  5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
5118  5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
5119      &'cross-section.'/1X,'Process switched off!')
5120  5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
5121  5500 FORMAT(1X,1P,8D11.3)
5122  5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
5123  5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
5124      &'MOD MOV   VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
5125  5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
5126  5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
5127      &'cross-section.'/1X,'Execution stopped!')
5128  6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
5129      &'cross-section maximum search',1X,8('*'))
5130  6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I  ISUB  ',
5131      &'Subprocess name',15X,'I  Maximum value  I'/11X,'I',38X,'I',
5132      &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
5133  6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
5134  6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
5135
5136       RETURN
5137       END
5138
5139 C*********************************************************************
5140
5141 *$ CREATE PYPILE.FOR
5142 *COPY PYPILE
5143 C...PYPILE
5144 C...Initializes multiplicity distribution and selects mutliplicity
5145 C...of pileup events, i.e. several events occuring at the same
5146 C...beam crossing.
5147
5148       SUBROUTINE PYPILE(MPILE)
5149
5150 C...Double precision and integer declarations.
5151       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5152       INTEGER PYK,PYCHGE,PYCOMP
5153 C...Commonblocks.
5154       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5155       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5156       COMMON/PYINT1/MINT(400),VINT(400)
5157       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5158       SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
5159 C...Local arrays and saved variables.
5160       DIMENSION WTI(0:200)
5161       SAVE IMIN,IMAX,WTI,WTS
5162
5163 C...Sum of allowed cross-sections for pileup events.
5164       IF(MPILE.EQ.1) THEN
5165         VINT(131)=SIGT(0,0,5)
5166         IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
5167         IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
5168         IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
5169         IF(MSTP(133).LE.0) RETURN
5170
5171 C...Initialize multiplicity distribution at maximum.
5172         XNAVE=VINT(131)*PARP(131)
5173         IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
5174         INAVE=MAX(1,MIN(200,NINT(XNAVE)))
5175         WTI(INAVE)=1D0
5176         WTS=WTI(INAVE)
5177         WTN=WTI(INAVE)*INAVE
5178
5179 C...Find shape of multiplicity distribution below maximum.
5180         IMIN=INAVE
5181         DO 100 I=INAVE-1,1,-1
5182           IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
5183           IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
5184           IF(WTI(I).LT.1D-6) GOTO 110
5185           WTS=WTS+WTI(I)
5186           WTN=WTN+WTI(I)*I
5187           IMIN=I
5188   100   CONTINUE
5189
5190 C...Find shape of multiplicity distribution above maximum.
5191   110   IMAX=INAVE
5192         DO 120 I=INAVE+1,200
5193           IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
5194           IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
5195           IF(WTI(I).LT.1D-6) GOTO 130
5196           WTS=WTS+WTI(I)
5197           WTN=WTN+WTI(I)*I
5198           IMAX=I
5199   120   CONTINUE
5200   130   VINT(132)=XNAVE
5201         VINT(133)=WTN/WTS
5202         IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
5203      &  WTS/(WTS+WTI(1)/XNAVE)
5204         IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
5205         IF(MSTP(133).GE.2) VINT(134)=XNAVE
5206
5207 C...Pick multiplicity of pileup events.
5208       ELSE
5209         IF(MSTP(133).LE.0) THEN
5210           MINT(81)=MAX(1,MSTP(134))
5211         ELSE
5212           WTR=WTS*PYR(0)
5213           DO 140 I=IMIN,IMAX
5214             MINT(81)=I
5215             WTR=WTR-WTI(I)
5216             IF(WTR.LE.0D0) GOTO 150
5217   140     CONTINUE
5218   150     CONTINUE
5219         ENDIF
5220       ENDIF
5221
5222 C...Format statement for error message.
5223  5000 FORMAT(1X,'Warning: requested average number of events per bunch',
5224      &'crossing too large, ',1P,D12.4)
5225
5226       RETURN
5227       END
5228
5229 C*********************************************************************
5230
5231 *$ CREATE PYSAVE.FOR
5232 *COPY PYSAVE
5233 C...PYSAVE
5234 C...Saves and restores parameter and cross section values for the
5235 C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random
5236 C...choice between alternatives.
5237
5238       SUBROUTINE PYSAVE(ISAVE,IGA)
5239
5240 C...Double precision and integer declarations.
5241       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5242       INTEGER PYK,PYCHGE,PYCOMP
5243 C...Commonblocks.
5244       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5245       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5246       COMMON/PYINT1/MINT(400),VINT(400)
5247       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5248       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5249       SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/
5250 C...Local arrays and saved variables.
5251       DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20),
5252      &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20)
5253       SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,INTCP,RECP
5254
5255 C...Save list of subprocesses and cross-section information.
5256       IF(ISAVE.EQ.1) THEN
5257         ICP=0
5258         DO 120 I=1,500
5259           IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
5260           ICP=ICP+1
5261           NSUBCP(IGA,ICP)=I
5262           MSUBCP(IGA,ICP)=MSUB(I)
5263           DO 100 J=1,20
5264             COEFCP(IGA,ICP,J)=COEF(I,J)
5265   100     CONTINUE
5266           DO 110 J=1,3
5267             NGENCP(IGA,ICP,J)=NGEN(I,J)
5268             XSECCP(IGA,ICP,J)=XSEC(I,J)
5269   110     CONTINUE
5270   120   CONTINUE
5271         NCP(IGA)=ICP
5272         DO 130 J=1,3
5273           NGENCP(IGA,0,J)=NGEN(0,J)
5274           XSECCP(IGA,0,J)=XSEC(0,J)
5275   130   CONTINUE
5276 C...Save various common process variables.
5277         DO 140 J=1,10
5278           INTCP(IGA,J)=MINT(40+J)
5279   140   CONTINUE
5280         INTCP(IGA,11)=MINT(101)
5281         INTCP(IGA,12)=MINT(102)
5282         INTCP(IGA,13)=MINT(107)
5283         INTCP(IGA,14)=MINT(108)
5284         INTCP(IGA,15)=MINT(123)
5285         RECP(IGA,1)=CKIN(3)
5286
5287 C...Save cross-section information only.
5288       ELSEIF(ISAVE.EQ.2) THEN
5289         DO 160 ICP=1,NCP(IGA)
5290           I=NSUBCP(IGA,ICP)
5291           DO 150 J=1,3
5292             NGENCP(IGA,ICP,J)=NGEN(I,J)
5293             XSECCP(IGA,ICP,J)=XSEC(I,J)
5294   150     CONTINUE
5295   160   CONTINUE
5296         DO 170 J=1,3
5297           NGENCP(IGA,0,J)=NGEN(0,J)
5298           XSECCP(IGA,0,J)=XSEC(0,J)
5299   170   CONTINUE
5300
5301 C...Choose between allowed alternatives.
5302       ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
5303         IF(ISAVE.EQ.4) THEN
5304           XSUMCP=0D0
5305           DO 180 IG=1,MINT(121)
5306             XSUMCP=XSUMCP+XSECCP(IG,0,1)
5307   180     CONTINUE
5308           XSUMCP=XSUMCP*PYR(0)
5309           DO 190 IG=1,MINT(121)
5310             IGA=IG
5311             XSUMCP=XSUMCP-XSECCP(IG,0,1)
5312             IF(XSUMCP.LE.0D0) GOTO 200
5313   190     CONTINUE
5314   200     CONTINUE
5315         ENDIF
5316
5317 C...Restore cross-section information.
5318         DO 210 I=1,500
5319           MSUB(I)=0
5320   210   CONTINUE
5321         DO 240 ICP=1,NCP(IGA)
5322           I=NSUBCP(IGA,ICP)
5323           MSUB(I)=MSUBCP(IGA,ICP)
5324           DO 220 J=1,20
5325             COEF(I,J)=COEFCP(IGA,ICP,J)
5326   220     CONTINUE
5327           DO 230 J=1,3
5328             NGEN(I,J)=NGENCP(IGA,ICP,J)
5329             XSEC(I,J)=XSECCP(IGA,ICP,J)
5330   230     CONTINUE
5331   240   CONTINUE
5332         DO 250 J=1,3
5333           NGEN(0,J)=NGENCP(IGA,0,J)
5334           XSEC(0,J)=XSECCP(IGA,0,J)
5335   250   CONTINUE
5336
5337 C...Restore various common process variables.
5338         DO 260 J=1,10
5339           MINT(40+J)=INTCP(IGA,J)
5340   260   CONTINUE
5341         MINT(101)=INTCP(IGA,11)
5342         MINT(102)=INTCP(IGA,12)
5343         MINT(107)=INTCP(IGA,13)
5344         MINT(108)=INTCP(IGA,14)
5345         MINT(123)=INTCP(IGA,15)
5346         CKIN(3)=RECP(IGA,1)
5347         CKIN(1)=2D0*CKIN(3)
5348
5349 C...Sum up cross-section info (for PYSTAT).
5350       ELSEIF(ISAVE.EQ.5) THEN
5351         DO 270 I=1,500
5352           MSUB(I)=0
5353           NGEN(I,1)=0
5354           NGEN(I,3)=0
5355           XSEC(I,3)=0D0
5356   270   CONTINUE
5357         NGEN(0,1)=0
5358         NGEN(0,2)=0
5359         NGEN(0,3)=0
5360         XSEC(0,3)=0
5361         DO 290 IG=1,MINT(121)
5362           DO 280 ICP=1,NCP(IG)
5363             I=NSUBCP(IG,ICP)
5364             IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
5365             NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
5366             NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
5367             XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
5368   280     CONTINUE
5369           NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
5370           NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
5371           NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
5372           XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
5373   290   CONTINUE
5374       ENDIF
5375
5376       RETURN
5377       END
5378
5379 C*********************************************************************
5380
5381 *$ CREATE PYRAND.FOR
5382 *COPY PYRAND
5383 C...PYRAND
5384 C...Generates quantities characterizing the high-pT scattering at the
5385 C...parton level according to the matrix elements. Chooses incoming,
5386 C...reacting partons, their momentum fractions and one of the possible
5387 C...subprocesses.
5388
5389       SUBROUTINE PYRAND
5390
5391 C...Double precision and integer declarations.
5392       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5393       INTEGER PYK,PYCHGE,PYCOMP
5394 C...Parameter statement to help give large particle numbers.
5395       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
5396 C...Commonblocks.
5397       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5398       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5399       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
5400       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5401       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5402       COMMON/PYINT1/MINT(400),VINT(400)
5403       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5404       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
5405       COMMON/PYINT4/MWID(500),WIDS(500,5)
5406       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5407       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
5408       COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
5409       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5410       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
5411      &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/PYMSSM/
5412 C...Local arrays.
5413       DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
5414
5415 C...Parameters and data used in elastic/diffractive treatment.
5416       DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
5417      &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
5418
5419 C...Initial values, specifically for (first) semihard interaction.
5420       MINT(10)=0
5421       MINT(17)=0
5422       MINT(18)=0
5423       VINT(143)=1D0
5424       VINT(144)=1D0
5425       MFAIL=0
5426       IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
5427       ISUB=0
5428       LOOP=0
5429   100 LOOP=LOOP+1
5430       MINT(51)=0
5431
5432 C...Choice of process type - first event of pileup.
5433       IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
5434
5435 C...For gamma-p or gamma-gamma first pick between alternatives.
5436         IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
5437         MINT(122)=IGA
5438
5439 C...For gamma + gamma with different nature, flip at random.
5440         IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
5441      &  PYR(0).GT.0.5D0) THEN
5442           MINTSV=MINT(41)
5443           MINT(41)=MINT(42)
5444           MINT(42)=MINTSV
5445           MINTSV=MINT(45)
5446           MINT(45)=MINT(46)
5447           MINT(46)=MINTSV
5448           MINTSV=MINT(107)
5449           MINT(107)=MINT(108)
5450           MINT(108)=MINTSV
5451           IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
5452         ENDIF
5453
5454 C...Pick process type.
5455         RSUB=XSEC(0,1)*PYR(0)
5456         DO 110 I=1,500
5457           IF(MSUB(I).NE.1) GOTO 110
5458           ISUB=I
5459           RSUB=RSUB-XSEC(I,1)
5460           IF(RSUB.LE.0D0) GOTO 120
5461   110   CONTINUE
5462   120   IF(ISUB.EQ.95) ISUB=96
5463         IF(ISUB.EQ.96) CALL PYMULT(2)
5464
5465 C...Choice of inclusive process type - pileup events.
5466       ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
5467         RSUB=VINT(131)*PYR(0)
5468         ISUB=96
5469         IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
5470         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
5471         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
5472         IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
5473      &  ISUB=91
5474         IF(ISUB.EQ.96) CALL PYMULT(2)
5475       ENDIF
5476       IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1
5477       IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1
5478       IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
5479      &NGEN(97,1)=NGEN(97,1)+1
5480       MINT(1)=ISUB
5481       ISTSB=ISET(ISUB)
5482
5483 C...Random choice of flavour for some SUSY processes.
5484       IF(ISUB.GE.201.AND.ISUB.LE.280) THEN
5485 C...~e_L ~nu_e or ~mu_L ~nu_mu.
5486         IF(ISUB.EQ.210) THEN
5487           KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
5488           KFPR(ISUB,2)=KFPR(ISUB,1)+1
5489 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
5490         ELSEIF(ISUB.EQ.213) THEN
5491           KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
5492           KFPR(ISUB,2)=KFPR(ISUB,1)
5493 C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
5494         ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
5495           IF(MOD(ISUB,2).EQ.0) THEN
5496             KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5497           ELSE
5498             KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5499           ENDIF
5500 C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.
5501         ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
5502           IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
5503             KSU1=KSUSY1
5504             KSU2=KSUSY1
5505           ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
5506             KSU1=KSUSY2
5507             KSU2=KSUSY2
5508           ELSEIF(PYR(0).LT.0.5D0) THEN
5509             KSU1=KSUSY1
5510             KSU2=KSUSY2
5511           ELSE
5512             KSU1=KSUSY2
5513             KSU2=KSUSY1
5514           ENDIF
5515           KFPR(ISUB,1)=KSU1+1+INT(5D0*PYR(0))
5516           KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0))
5517 C...~q ~q(bar);  ~q = ~d, ~u, ~s, ~c or ~b.
5518         ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
5519           KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0))
5520           KFPR(ISUB,2)=KFPR(ISUB,1)
5521         ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
5522           KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0))
5523           KFPR(ISUB,2)=KFPR(ISUB,1)
5524         ENDIF
5525       ENDIF
5526
5527 C...Find resonances (explicit or implicit in cross-section).
5528       MINT(72)=0
5529       KFR1=0
5530       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
5531         KFR1=KFPR(ISUB,1)
5532       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
5533      &  ISUB.EQ.171.OR.ISUB.EQ.176) THEN
5534         KFR1=23
5535       ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
5536      &  ISUB.EQ.177) THEN
5537         KFR1=24
5538       ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
5539         KFR1=25
5540         IF(MSTP(46).EQ.5) THEN
5541           KFR1=30
5542           PMAS(30,1)=PARP(45)
5543           PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
5544         ENDIF
5545       ELSEIF(ISUB.EQ.194) THEN
5546         KFR1=54
5547       ENDIF
5548       CKMX=CKIN(2)
5549       IF(CKMX.LE.0D0) CKMX=VINT(1)
5550       KCR1=PYCOMP(KFR1)
5551       IF(KFR1.NE.0) THEN
5552         IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
5553      &  CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
5554       ENDIF
5555       IF(KFR1.NE.0) THEN
5556         TAUR1=PMAS(KCR1,1)**2/VINT(2)
5557         GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
5558         MINT(72)=1
5559         MINT(73)=KFR1
5560         VINT(73)=TAUR1
5561         VINT(74)=GAMR1
5562       ENDIF
5563       IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN
5564         KFR2=23
5565         IF(ISUB.EQ.194) KFR2=56
5566         KCR2=PYCOMP(KFR2)
5567         TAUR2=PMAS(KCR2,1)**2/VINT(2)
5568         GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
5569         IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
5570      &  CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
5571         IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
5572           MINT(72)=2
5573           MINT(74)=KFR2
5574           VINT(75)=TAUR2
5575           VINT(76)=GAMR2
5576         ELSEIF(KFR2.NE.0) THEN
5577           KFR1=KFR2
5578           TAUR1=TAUR2
5579           GAMR1=GAMR2
5580           MINT(72)=1
5581           MINT(73)=KFR1
5582           VINT(73)=TAUR1
5583           VINT(74)=GAMR1
5584         ENDIF
5585       ENDIF
5586
5587 C...Find product masses and minimum pT of process,
5588 C...optionally with broadening according to a truncated Breit-Wigner.
5589       VINT(63)=0D0
5590       VINT(64)=0D0
5591       MINT(71)=0
5592       VINT(71)=CKIN(3)
5593       IF(MINT(82).GE.2) VINT(71)=0D0
5594       VINT(80)=1D0
5595       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5596         NBW=0
5597         DO 140 I=1,2
5598           PMMN(I)=0D0
5599           IF(KFPR(ISUB,I).EQ.0) THEN
5600           ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
5601      &      PARP(41)) THEN
5602             VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
5603           ELSE
5604             NBW=NBW+1
5605 C...This prevents SUSY/t particles from becoming too light.
5606             KFLW=KFPR(ISUB,I)
5607             IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
5608               KCW=PYCOMP(KFLW)
5609               PMMN(I)=PMAS(KCW,1)
5610               DO 130 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
5611                 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
5612                   PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
5613      &            PMAS(PYCOMP(KFDP(IDC,2)),1)
5614                   IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
5615      &            PMAS(PYCOMP(KFDP(IDC,3)),1)
5616                   PMMN(I)=MIN(PMMN(I),PMSUM)
5617                 ENDIF
5618   130         CONTINUE
5619             ELSEIF(KFLW.EQ.6) THEN
5620               PMMN(I)=PMAS(24,1)+PMAS(5,1)
5621             ENDIF
5622           ENDIF
5623   140   CONTINUE
5624         IF(NBW.GE.1) THEN
5625           CKIN41=CKIN(41)
5626           CKIN43=CKIN(43)
5627           CKIN(41)=MAX(PMMN(1),CKIN(41))
5628           CKIN(43)=MAX(PMMN(2),CKIN(43))
5629           CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
5630           CKIN(41)=CKIN41
5631           CKIN(43)=CKIN43
5632           IF(MINT(51).EQ.1) THEN
5633             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5634             IF(MFAIL.EQ.1) THEN
5635               MSTI(61)=1
5636               RETURN
5637             ENDIF
5638             GOTO 100
5639           ENDIF
5640           VINT(63)=PQM3**2
5641           VINT(64)=PQM4**2
5642         ENDIF
5643         IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
5644         IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
5645       ENDIF
5646
5647 C...Prepare for additional variable choices in 2 -> 3.
5648       IF(ISTSB.EQ.5) THEN
5649         VINT(201)=0D0
5650         IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
5651         VINT(206)=VINT(201)
5652         VINT(204)=PMAS(23,1)
5653         IF(ISUB.EQ.124) VINT(204)=PMAS(24,1)
5654         IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
5655      &  ISUB.EQ.186.OR.ISUB.EQ.187) VINT(204)=VINT(201)
5656         VINT(209)=VINT(204)
5657       ENDIF
5658
5659 C...Select incoming VDM particle (rho/omega/phi/J/psi).
5660       IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
5661      &(MINT(123).EQ.2.OR.MINT(123).EQ.5.OR.MINT(123).EQ.7)) THEN
5662         VRN=PYR(0)*SIGT(0,0,5)
5663         IF(MINT(101).LE.1) THEN
5664           I1MN=0
5665           I1MX=0
5666         ELSE
5667           I1MN=1
5668           I1MX=MINT(101)
5669         ENDIF
5670         IF(MINT(102).LE.1) THEN
5671           I2MN=0
5672           I2MX=0
5673         ELSE
5674           I2MN=1
5675           I2MX=MINT(102)
5676         ENDIF
5677         DO 160 I1=I1MN,I1MX
5678           KFV1=110*I1+3
5679           DO 150 I2=I2MN,I2MX
5680             KFV2=110*I2+3
5681             VRN=VRN-SIGT(I1,I2,5)
5682             IF(VRN.LE.0D0) GOTO 170
5683   150     CONTINUE
5684   160   CONTINUE
5685   170   IF(MINT(101).GE.2) MINT(103)=KFV1
5686         IF(MINT(102).GE.2) MINT(104)=KFV2
5687       ENDIF
5688
5689       IF(ISTSB.EQ.0) THEN
5690 C...Elastic scattering or single or double diffractive scattering.
5691
5692 C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
5693         MINT(103)=MINT(11)
5694         MINT(104)=MINT(12)
5695         PMM(1)=VINT(3)
5696         PMM(2)=VINT(4)
5697         IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
5698           JJ=ISUB-90
5699           VRN=PYR(0)*SIGT(0,0,JJ)
5700           IF(MINT(101).LE.1) THEN
5701             I1MN=0
5702             I1MX=0
5703           ELSE
5704             I1MN=1
5705             I1MX=MINT(101)
5706           ENDIF
5707           IF(MINT(102).LE.1) THEN
5708             I2MN=0
5709             I2MX=0
5710           ELSE
5711             I2MN=1
5712             I2MX=MINT(102)
5713           ENDIF
5714           DO 190 I1=I1MN,I1MX
5715             KFV1=110*I1+3
5716             DO 180 I2=I2MN,I2MX
5717               KFV2=110*I2+3
5718               VRN=VRN-SIGT(I1,I2,JJ)
5719               IF(VRN.LE.0D0) GOTO 200
5720   180       CONTINUE
5721   190     CONTINUE
5722   200     IF(MINT(101).GE.2) THEN
5723             MINT(103)=KFV1
5724             PMM(1)=PYMASS(KFV1)
5725           ENDIF
5726           IF(MINT(102).GE.2) THEN
5727             MINT(104)=KFV2
5728             PMM(2)=PYMASS(KFV2)
5729           ENDIF
5730         ENDIF
5731
5732 C...Side/sides of diffractive system.
5733         MINT(17)=0
5734         MINT(18)=0
5735         IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
5736         IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
5737
5738 C...Find masses of particles and minimal masses of diffractive states.
5739         DO 210 JT=1,2
5740           PDIF(JT)=PMM(JT)
5741           VINT(66+JT)=PDIF(JT)
5742           IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
5743   210   CONTINUE
5744         SH=VINT(2)
5745         SQM1=PMM(1)**2
5746         SQM2=PMM(2)**2
5747         SQM3=PDIF(1)**2
5748         SQM4=PDIF(2)**2
5749         SMRES1=(PMM(1)+PMRC)**2
5750         SMRES2=(PMM(2)+PMRC)**2
5751
5752 C...Find elastic slope and lower limit diffractive slope.
5753         IHA=MAX(2,IABS(MINT(103))/110)
5754         IF(IHA.GE.5) IHA=1
5755         IHB=MAX(2,IABS(MINT(104))/110)
5756         IF(IHB.GE.5) IHB=1
5757         IF(ISUB.EQ.91) THEN
5758           BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
5759         ELSEIF(ISUB.EQ.92) THEN
5760           BMN=MAX(2D0,2D0*BHAD(IHB))
5761         ELSEIF(ISUB.EQ.93) THEN
5762           BMN=MAX(2D0,2D0*BHAD(IHA))
5763         ELSEIF(ISUB.EQ.94) THEN
5764           BMN=2D0*ALP*4D0
5765         ENDIF
5766
5767 C...Determine maximum possible t range and coefficient of generation.
5768         SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
5769         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5770         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5771         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5772         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5773      &  (SQM1*SQM4-SQM2*SQM3)/SH
5774         THL=-0.5D0*(THA+THB)
5775         THU=THC/THL
5776         THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
5777
5778 C...Select diffractive mass/masses according to dm^2/m^2.
5779   220   DO 230 JT=1,2
5780           IF(MINT(16+JT).EQ.0) THEN
5781             PDIF(2+JT)=PDIF(JT)
5782           ELSE
5783             PMMIN=PDIF(JT)
5784             PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
5785             PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
5786           ENDIF
5787   230   CONTINUE
5788         SQM3=PDIF(3)**2
5789         SQM4=PDIF(4)**2
5790
5791 C..Additional mass factors, including resonance enhancement.
5792         IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220
5793         IF(ISUB.EQ.92) THEN
5794           FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
5795           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5796         ELSEIF(ISUB.EQ.93) THEN
5797           FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
5798           IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220
5799         ELSEIF(ISUB.EQ.94) THEN
5800           FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
5801      &    (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
5802      &    (1D0+CRES*SMRES2/(SMRES2+SQM4))
5803           IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 220
5804         ENDIF
5805
5806 C...Select t according to exp(Bmn*t) and correct to right slope.
5807         TH=THU+LOG(1D0+THRND*PYR(0))/BMN
5808         IF(ISUB.GE.92) THEN
5809           IF(ISUB.EQ.92) THEN
5810             BADD=2D0*ALP*LOG(SH/SQM3)
5811             IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
5812           ELSEIF(ISUB.EQ.93) THEN
5813             BADD=2D0*ALP*LOG(SH/SQM4)
5814             IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
5815           ELSEIF(ISUB.EQ.94) THEN
5816             BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
5817           ENDIF
5818           IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 220
5819         ENDIF
5820
5821 C...Check whether m^2 and t choices are consistent.
5822         SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
5823         THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
5824         THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
5825         IF(THB.LE.1D-8) GOTO 220
5826         THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
5827      &  (SQM1*SQM4-SQM2*SQM3)/SH
5828         THLM=-0.5D0*(THA+THB)
5829         THUM=THC/THLM
5830         IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 220
5831
5832 C...Information to output.
5833         VINT(21)=1D0
5834         VINT(22)=0D0
5835         VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
5836         VINT(45)=TH
5837         VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
5838         VINT(63)=PDIF(3)**2
5839         VINT(64)=PDIF(4)**2
5840
5841 C...Note: in the following, by In is meant the integral over the
5842 C...quantity multiplying coefficient cn.
5843 C...Choose tau according to h1(tau)/tau, where
5844 C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
5845 C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
5846 C...I1/I5*c5*1/(tau+tau_R') +
5847 C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
5848 C...I1/I7*c7*tau/(1.-tau), and
5849 C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
5850       ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
5851         CALL PYKLIM(1)
5852         IF(MINT(51).NE.0) THEN
5853           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5854           IF(MFAIL.EQ.1) THEN
5855             MSTI(61)=1
5856             RETURN
5857           ENDIF
5858           GOTO 100
5859         ENDIF
5860         RTAU=PYR(0)
5861         MTAU=1
5862         IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
5863         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
5864         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
5865         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
5866      &  MTAU=5
5867         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5868      &  COEF(ISUB,5)) MTAU=6
5869         IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
5870      &  COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
5871         CALL PYKMAP(1,MTAU,PYR(0))
5872
5873 C...2 -> 3, 4 processes:
5874 C...Choose tau' according to h4(tau,tau')/tau', where
5875 C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
5876 C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
5877         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
5878           CALL PYKLIM(4)
5879           IF(MINT(51).NE.0) THEN
5880             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5881             IF(MFAIL.EQ.1) THEN
5882               MSTI(61)=1
5883               RETURN
5884             ENDIF
5885             GOTO 100
5886           ENDIF
5887           RTAUP=PYR(0)
5888           MTAUP=1
5889           IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
5890           IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
5891           CALL PYKMAP(4,MTAUP,PYR(0))
5892         ENDIF
5893
5894 C...Choose y* according to h2(y*), where
5895 C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
5896 C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
5897 C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
5898 C...and c1 + c2 + c3 + c4 + c5 = 1.
5899         CALL PYKLIM(2)
5900         IF(MINT(51).NE.0) THEN
5901           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5902           IF(MFAIL.EQ.1) THEN
5903             MSTI(61)=1
5904             RETURN
5905           ENDIF
5906           GOTO 100
5907         ENDIF
5908         RYST=PYR(0)
5909         MYST=1
5910         IF(RYST.GT.COEF(ISUB,8)) MYST=2
5911         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
5912         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
5913         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
5914      &  COEF(ISUB,11)) MYST=5
5915         CALL PYKMAP(2,MYST,PYR(0))
5916
5917 C...2 -> 2 processes:
5918 C...Choose cos(theta-hat) (cth) according to h3(cth), where
5919 C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
5920 C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
5921 C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
5922 C...and c0 + c1 + c2 + c3 + c4 = 1.
5923         CALL PYKLIM(3)
5924         IF(MINT(51).NE.0) THEN
5925           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5926           IF(MFAIL.EQ.1) THEN
5927             MSTI(61)=1
5928             RETURN
5929           ENDIF
5930           GOTO 100
5931         ENDIF
5932         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
5933           RCTH=PYR(0)
5934           MCTH=1
5935           IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
5936           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
5937           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
5938           IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
5939      &    COEF(ISUB,16)) MCTH=5
5940           CALL PYKMAP(3,MCTH,PYR(0))
5941         ENDIF
5942
5943 C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
5944         IF(ISTSB.EQ.5) THEN
5945           CALL PYKMAP(5,0,0D0)
5946           IF(MINT(51).NE.0) THEN
5947             IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5948             IF(MFAIL.EQ.1) THEN
5949               MSTI(61)=1
5950               RETURN
5951             ENDIF
5952             GOTO 100
5953           ENDIF
5954         ENDIF
5955
5956 C...Low-pT or multiple interactions (first semihard interaction).
5957       ELSEIF(ISTSB.EQ.9) THEN
5958         CALL PYMULT(3)
5959         ISUB=MINT(1)
5960
5961 C...Generate user-defined process: kinematics plus weight.
5962       ELSEIF(ISTSB.EQ.11) THEN
5963         MSTI(51)=0
5964         CALL PYUPEV(ISUB,SIGS)
5965         IF(NUP.LE.0) THEN
5966           MINT(51)=2
5967           MSTI(51)=1
5968           IF(MINT(82).EQ.1) THEN
5969             NGEN(0,1)=NGEN(0,1)-1
5970             NGEN(0,2)=NGEN(0,2)-1
5971             NGEN(ISUB,1)=NGEN(ISUB,1)-1
5972           ENDIF
5973           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
5974           RETURN
5975         ENDIF
5976
5977 C...Construct 'trivial' kinematical variables needed.
5978         KFL1=KUP(1,2)
5979         KFL2=KUP(2,2)
5980         VINT(41)=2D0*PUP(1,4)/VINT(1)
5981         VINT(42)=2D0*PUP(2,4)/VINT(1)
5982         VINT(21)=VINT(41)*VINT(42)
5983         VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
5984         VINT(44)=VINT(21)*VINT(2)
5985         VINT(43)=SQRT(MAX(0D0,VINT(44)))
5986         VINT(56)=Q2UP(0)
5987         VINT(55)=SQRT(MAX(0D0,VINT(56)))
5988
5989 C...Construct other kinematical variables needed (approximately).
5990         VINT(23)=0D0
5991         VINT(26)=VINT(21)
5992         VINT(45)=-0.5D0*VINT(44)
5993         VINT(46)=-0.5D0*VINT(44)
5994         VINT(49)=VINT(43)
5995         VINT(50)=VINT(44)
5996         VINT(51)=VINT(55)
5997         VINT(52)=VINT(56)
5998         VINT(53)=VINT(55)
5999         VINT(54)=VINT(56)
6000         VINT(25)=0D0
6001         VINT(48)=0D0
6002         DO 240 IUP=3,NUP
6003           IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+
6004      &    PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1)
6005           IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+
6006      &    PUP(IUP,2)**2)
6007   240   CONTINUE
6008         VINT(47)=SQRT(VINT(48))
6009
6010 C...Calculate parton distribution weights.
6011         IF(MINT(47).GE.2) THEN
6012           DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
6013             MINT(105)=MINT(102+I)
6014             MINT(109)=MINT(106+I)
6015             IF(MSTP(57).LE.1) THEN
6016               CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6017             ELSE
6018               CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ)
6019             ENDIF
6020             DO 250 KFL=-25,25
6021               XSFX(I,KFL)=XPQ(KFL)
6022   250       CONTINUE
6023   260     CONTINUE
6024         ENDIF
6025       ENDIF
6026
6027 C...Choose azimuthal angle.
6028       VINT(24)=PARU(2)*PYR(0)
6029
6030 C...Check against user cuts on kinematics at parton level.
6031       MINT(51)=0
6032       IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
6033       IF(MINT(51).NE.0) THEN
6034         IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6035         IF(MFAIL.EQ.1) THEN
6036           MSTI(61)=1
6037           RETURN
6038         ENDIF
6039         GOTO 100
6040       ENDIF
6041       IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
6042         MCUT=0
6043         IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
6044      &  CALL PYKCUT(MCUT)
6045         IF(MCUT.NE.0) THEN
6046           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6047           IF(MFAIL.EQ.1) THEN
6048             MSTI(61)=1
6049             RETURN
6050           ENDIF
6051           GOTO 100
6052         ENDIF
6053       ENDIF
6054
6055 C...Calculate differential cross-section for different subprocesses.
6056       IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
6057       SIGSOR=SIGS
6058       SIGLPT=SIGT(0,0,5)
6059
6060 C...Multiply cross-section by user-defined weights.
6061       IF(MSTP(173).EQ.1) THEN
6062         SIGS=PARP(173)*SIGS
6063         DO 270 ICHN=1,NCHN
6064           SIGH(ICHN)=PARP(173)*SIGH(ICHN)
6065   270   CONTINUE
6066         SIGLPT=PARP(173)*SIGLPT
6067       ENDIF
6068       WTXS=1D0
6069       SIGSWT=SIGS
6070       VINT(99)=1D0
6071       VINT(100)=1D0
6072       IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
6073         IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
6074      &  MSUB(95).EQ.0) CALL PYEVWT(WTXS)
6075         SIGSWT=WTXS*SIGS
6076         VINT(99)=WTXS
6077         IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
6078       ENDIF
6079
6080 C...Calculations for Monte Carlo estimate of all cross-sections.
6081       IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
6082         IF(MSTP(142).LE.1) THEN
6083           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6084         ELSE
6085           XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
6086         ENDIF
6087       ELSEIF(MINT(82).EQ.1) THEN
6088         XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
6089       ENDIF
6090       IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP.EQ.1.AND.MINT(82).EQ.1)
6091      &XSEC(97,2)=XSEC(97,2)+SIGLPT
6092
6093 C...Multiple interactions: store results of cross-section calculation.
6094       IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
6095         VINT(153)=SIGSOR
6096         CALL PYMULT(4)
6097       ENDIF
6098
6099 C...Check that weight not negative.
6100       VIOL=SIGSWT/XSEC(ISUB,1)
6101       IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
6102       IF(MSTP(123).LE.0) THEN
6103         IF(VIOL.LT.-1D-3) THEN
6104           WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
6105           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6106      &    VINT(22),VINT(23),VINT(26)
6107           STOP
6108         ENDIF
6109       ELSE
6110         IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
6111           VINT(109)=VIOL
6112           WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
6113           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
6114      &    VINT(22),VINT(23),VINT(26)
6115         ENDIF
6116       ENDIF
6117
6118 C...Weighting using estimate of maximum of differential cross-section.
6119       IF(MFAIL.EQ.0) THEN
6120         IF(VIOL.LT.PYR(0)) THEN
6121           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6122           GOTO 100
6123         ENDIF
6124       ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
6125         IF(VIOL.LT.PYR(0)) THEN
6126           MSTI(61)=1
6127           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6128           RETURN
6129         ENDIF
6130       ELSE
6131         RATND=SIGLPT/XSEC(95,1)
6132         IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
6133           MSTI(61)=1
6134           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6135           RETURN
6136         ENDIF
6137         VIOL=VIOL/RATND
6138         IF(VIOL.LT.PYR(0)) THEN
6139           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6140           GOTO 100
6141         ENDIF
6142       ENDIF
6143
6144 C...Check for possible violation of estimated maximum of differential
6145 C...cross-section used in weighting.
6146       IF(MSTP(123).LE.0) THEN
6147         IF(VIOL.GT.1D0) THEN
6148           WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
6149           IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6150      &    VINT(22),VINT(23),VINT(26)
6151           STOP
6152         ENDIF
6153       ELSEIF(MSTP(123).EQ.1) THEN
6154         IF(VIOL.GT.VINT(108)) THEN
6155           VINT(108)=VIOL
6156           IF(VIOL.GT.1D0) THEN
6157             MINT(10)=1
6158             WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6159             IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6160      &      VINT(22),VINT(23),VINT(26)
6161           ENDIF
6162         ENDIF
6163       ELSEIF(VIOL.GT.VINT(108)) THEN
6164         VINT(108)=VIOL
6165         IF(VIOL.GT.1D0) THEN
6166           MINT(10)=1
6167           XDIF=XSEC(ISUB,1)*(VIOL-1D0)
6168           XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
6169           IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
6170      &    XSEC(0,1)=XSEC(0,1)+XDIF
6171           WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
6172           IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
6173      &    VINT(22),VINT(23),VINT(26)
6174           IF(ISUB.LE.9) THEN
6175             WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
6176           ELSEIF(ISUB.LE.99) THEN
6177             WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
6178           ELSE
6179             WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
6180           ENDIF
6181           VINT(108)=1D0
6182         ENDIF
6183       ENDIF
6184
6185 C...Multiple interactions: choose impact parameter.
6186       VINT(148)=1D0
6187       IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
6188      &MSTP(82).GE.3) THEN
6189         CALL PYMULT(5)
6190         IF(VINT(150).LT.PYR(0)) THEN
6191           IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6192           IF(MFAIL.EQ.1) THEN
6193             MSTI(61)=1
6194             RETURN
6195           ENDIF
6196           GOTO 100
6197         ENDIF
6198       ENDIF
6199       IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
6200       IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
6201         IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+1
6202         IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
6203       ENDIF
6204       IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
6205
6206 C...Choose flavour of reacting partons (and subprocess).
6207       IF(ISTSB.GE.11) GOTO 290
6208       RSIGS=SIGS*PYR(0)
6209       QT2=VINT(48)
6210       RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2)
6211       IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
6212      &PYR(0).GT.RQQBAR)) THEN
6213         DO 280 ICHN=1,NCHN
6214           KFL1=ISIG(ICHN,1)
6215           KFL2=ISIG(ICHN,2)
6216           MINT(2)=ISIG(ICHN,3)
6217           RSIGS=RSIGS-SIGH(ICHN)
6218           IF(RSIGS.LE.0D0) GOTO 290
6219   280   CONTINUE
6220
6221 C...Multiple interactions: choose qqbar preferentially at small pT.
6222       ELSEIF(ISUB.EQ.96) THEN
6223         MINT(105)=MINT(103)
6224         MINT(109)=MINT(107)
6225         CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
6226         MINT(105)=MINT(104)
6227         MINT(109)=MINT(108)
6228         CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
6229         MINT(1)=11
6230         MINT(2)=1
6231         IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
6232
6233 C...Low-pT: choose string drawing configuration.
6234       ELSE
6235         KFL1=21
6236         KFL2=21
6237         RSIGS=6D0*PYR(0)
6238         MINT(2)=1
6239         IF(RSIGS.GT.1D0) MINT(2)=2
6240         IF(RSIGS.GT.2D0) MINT(2)=3
6241       ENDIF
6242
6243 C...Reassign QCD process. Partons before initial state radiation.
6244   290 IF(MINT(2).GT.10) THEN
6245         MINT(1)=MINT(2)/10
6246         MINT(2)=MOD(MINT(2),10)
6247       ENDIF
6248       IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
6249      &NGEN(MINT(1),2)+1
6250       MINT(15)=KFL1
6251       MINT(16)=KFL2
6252       MINT(13)=MINT(15)
6253       MINT(14)=MINT(16)
6254       VINT(141)=VINT(41)
6255       VINT(142)=VINT(42)
6256       VINT(151)=0D0
6257       VINT(152)=0D0
6258
6259 C...Calculate x value of photon for parton inside photon inside e.
6260       DO 320 JT=1,2
6261         MINT(18+JT)=0
6262         VINT(154+JT)=0D0
6263         MSPLI=0
6264         IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
6265         IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
6266         IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
6267         IF(MSPLI.EQ.2) THEN
6268           KFLH=MINT(14+JT)
6269           XHRD=VINT(140+JT)
6270           Q2HRD=VINT(54)
6271           MINT(105)=MINT(102+JT)
6272           MINT(109)=MINT(106+JT)
6273           IF(MSTP(57).LE.1) THEN
6274             CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
6275           ELSE
6276             CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
6277           ENDIF
6278           WTMX=4D0*XPQ(KFLH)
6279           IF(MSTP(13).EQ.2) THEN
6280             Q2PMS=Q2HRD/PMAS(11,1)**2
6281             WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
6282           ENDIF
6283   300     XE=XHRD**PYR(0)
6284           XG=MIN(0.999999D0,XHRD/XE)
6285           IF(MSTP(57).LE.1) THEN
6286             CALL PYPDFU(22,XG,Q2HRD,XPQ)
6287           ELSE
6288             CALL PYPDFL(22,XG,Q2HRD,XPQ)
6289           ENDIF
6290           WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
6291           IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
6292           IF(WT.LT.PYR(0)*WTMX) GOTO 300
6293           MINT(18+JT)=1
6294           VINT(154+JT)=XE
6295           DO 310 KFLS=-25,25
6296             XSFX(JT,KFLS)=XPQ(KFLS)
6297   310     CONTINUE
6298         ENDIF
6299   320 CONTINUE
6300
6301 C...Pick scale where photon is resolved.
6302       IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2*
6303      &(VINT(54)/PARP(15)**2)**PYR(0)
6304       IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2*
6305      &(VINT(54)/PARP(15)**2)**PYR(0)
6306       IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
6307
6308 C...Format statements for differential cross-section maximum violations.
6309  5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
6310      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6311  5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
6312      &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
6313  5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
6314      &'in event',1X,I7)
6315  5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
6316      &'in event',1X,I7,'D0'/1X,'Execution stopped!')
6317  5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
6318      &'in event',1X,I7)
6319  5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
6320  5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
6321  5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
6322
6323       RETURN
6324       END
6325
6326 C*********************************************************************
6327
6328 *$ CREATE PYSCAT.FOR
6329 *COPY PYSCAT
6330 C...PYSCAT
6331 C...Finds outgoing flavours and event type; sets up the kinematics
6332 C...and colour flow of the hard scattering
6333
6334       SUBROUTINE PYSCAT
6335
6336 C...Double precision and integer declarations
6337       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6338       INTEGER PYK,PYCHGE,PYCOMP
6339 C...Parameter statement to help give large particle numbers.
6340       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
6341 C...Commonblocks
6342       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
6343       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6344       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6345       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
6346       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6347       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6348       COMMON/PYINT1/MINT(400),VINT(400)
6349       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6350       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6351       COMMON/PYINT4/MWID(500),WIDS(500,5)
6352       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6353       COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
6354       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
6355      &SFMIX(16,4)
6356       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
6357      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/
6358 C...Local arrays and saved variables
6359       DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2),
6360      &PHI(2),KUPPO(20),VINTSV(41:66)
6361       SAVE VINTSV
6362
6363 C...Read out process
6364       ISUB=MINT(1)
6365       ISUBSV=ISUB
6366
6367 C...Restore information for low-pT processes
6368       IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
6369         DO 100 J=41,66
6370   100   VINT(J)=VINTSV(J)
6371       ENDIF
6372
6373 C...Convert H' or A process into equivalent H one
6374       IHIGG=1
6375       KFHIGG=25
6376       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
6377      &ISUB.LE.190)) THEN
6378         IHIGG=2
6379         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
6380         KFHIGG=33+IHIGG
6381         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
6382         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
6383         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
6384         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
6385         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
6386         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
6387         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
6388         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
6389         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
6390       ENDIF
6391
6392 C...Choice of subprocess, number of documentation lines
6393       IDOC=6+ISET(ISUB)
6394       IF(ISUB.EQ.95) IDOC=8
6395       IF(ISET(ISUB).EQ.5) IDOC=9
6396       IF(ISET(ISUB).EQ.11) IDOC=4+NUP
6397       MINT(3)=IDOC-6
6398       IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
6399       MINT(4)=IDOC
6400       IPU1=MINT(84)+1
6401       IPU2=MINT(84)+2
6402       IPU3=MINT(84)+3
6403       IPU4=MINT(84)+4
6404       IPU5=MINT(84)+5
6405       IPU6=MINT(84)+6
6406
6407 C...Reset K, P and V vectors. Store incoming particles
6408       DO 120 JT=1,MSTP(126)+20
6409         I=MINT(83)+JT
6410         DO 110 J=1,5
6411           K(I,J)=0
6412           P(I,J)=0D0
6413           V(I,J)=0D0
6414   110   CONTINUE
6415   120 CONTINUE
6416       DO 140 JT=1,2
6417         I=MINT(83)+JT
6418         K(I,1)=21
6419         K(I,2)=MINT(10+JT)
6420         DO 130 J=1,5
6421           P(I,J)=VINT(285+5*JT+J)
6422   130   CONTINUE
6423   140 CONTINUE
6424       MINT(6)=2
6425       KFRES=0
6426
6427 C...Store incoming partons in their CM-frame
6428       SH=VINT(44)
6429       SHR=SQRT(SH)
6430       SHP=VINT(26)*VINT(2)
6431       SHPR=SQRT(SHP)
6432       SHUSER=SHR
6433       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
6434       DO 150 JT=1,2
6435         I=MINT(84)+JT
6436         K(I,1)=14
6437         K(I,2)=MINT(14+JT)
6438         K(I,3)=MINT(83)+2+JT
6439         P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
6440         P(I,4)=0.5D0*SHUSER
6441   150 CONTINUE
6442
6443 C...Copy incoming partons to documentation lines
6444       DO 170 JT=1,2
6445         I1=MINT(83)+4+JT
6446         I2=MINT(84)+JT
6447         K(I1,1)=21
6448         K(I1,2)=K(I2,2)
6449         K(I1,3)=I1-2
6450         DO 160 J=1,5
6451           P(I1,J)=P(I2,J)
6452   160   CONTINUE
6453   170 CONTINUE
6454
6455 C...Choose new quark/lepton flavour for relevant annihilation graphs
6456       IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58) THEN
6457         IGLGA=21
6458         IF(ISUB.EQ.58) IGLGA=22
6459         CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
6460   180   RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
6461         DO 190 I=1,MDCY(IGLGA,3)
6462           KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
6463           RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
6464           IF(RKFL.LE.0D0) GOTO 200
6465   190   CONTINUE
6466   200   CONTINUE
6467         IF(ISUB.EQ.12.AND.MSTP(5).EQ.1.AND.IABS(MINT(15)).LE.2.AND.
6468      &  IABS(KFLF).GE.3) THEN
6469           FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
6470      &    VINT(44)**2
6471           FACCIB=VINT(46)**2/PARU(155)**4
6472           IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
6473         ELSEIF(ISUB.EQ.54) THEN
6474           IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
6475         ELSEIF(ISUB.EQ.58) THEN
6476           IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
6477         ENDIF
6478       ENDIF
6479
6480 C...Final state flavours and colour flow: default values
6481       JS=1
6482       MINT(21)=MINT(15)
6483       MINT(22)=MINT(16)
6484       MINT(23)=0
6485       MINT(24)=0
6486       KCC=20
6487       KCS=ISIGN(1,MINT(15))
6488
6489       IF(ISET(ISUB).EQ.11) THEN
6490 C...User-defined processes: find products
6491         IRUP=0
6492         DO 210 IUP=3,NUP
6493           IF(KUP(IUP,1).NE.1) THEN
6494           ELSEIF(IRUP.LE.5) THEN
6495             IRUP=IRUP+1
6496             MINT(20+IRUP)=KUP(IUP,2)
6497           ENDIF
6498   210   CONTINUE
6499
6500       ELSEIF(ISUB.LE.10) THEN
6501         IF(ISUB.EQ.1) THEN
6502 C...f + fbar -> gamma*/Z0
6503           KFRES=23
6504
6505         ELSEIF(ISUB.EQ.2) THEN
6506 C...f + fbar' -> W+/-
6507           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6508           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6509           KFRES=ISIGN(24,KCH1+KCH2)
6510
6511         ELSEIF(ISUB.EQ.3) THEN
6512 C...f + fbar -> h0 (or H0, or A0)
6513           KFRES=KFHIGG
6514
6515         ELSEIF(ISUB.EQ.4) THEN
6516 C...gamma + W+/- -> W+/-
6517
6518         ELSEIF(ISUB.EQ.5) THEN
6519 C...Z0 + Z0 -> h0
6520           XH=SH/SHP
6521           MINT(21)=MINT(15)
6522           MINT(22)=MINT(16)
6523           PMQ(1)=PYMASS(MINT(21))
6524           PMQ(2)=PYMASS(MINT(22))
6525   220     JT=INT(1.5D0+PYR(0))
6526           ZMIN=2D0*PMQ(JT)/SHPR
6527           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6528      &    (SHPR*(SHPR-PMQ(3-JT)))
6529           ZMAX=MIN(1D0-XH,ZMAX)
6530           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6531           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6532      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
6533           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6534           IF(SQC1.LT.1.D-8) GOTO 220
6535           C1=SQRT(SQC1)
6536           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6537           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6538           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6539           Z(3-JT)=1D0-XH/(1D0-Z(JT))
6540           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6541           IF(SQC1.LT.1.D-8) GOTO 220
6542           C1=SQRT(SQC1)
6543           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6544           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6545           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6546           PHIR=PARU(2)*PYR(0)
6547           CPHI=COS(PHIR)
6548           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6549      &    SQRT(1D0-CTHE(2)**2)*CPHI
6550           Z1=2D0-Z(JT)
6551           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6552           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6553           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6554      &    PMQ(3-JT)**2/SHP))
6555           ZMIN=2D0*PMQ(3-JT)/SHPR
6556           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6557           ZMAX=MIN(1D0-XH,ZMAX)
6558           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
6559           KCC=22
6560           KFRES=25
6561
6562         ELSEIF(ISUB.EQ.6) THEN
6563 C...Z0 + W+/- -> W+/-
6564
6565         ELSEIF(ISUB.EQ.7) THEN
6566 C...W+ + W- -> Z0
6567
6568         ELSEIF(ISUB.EQ.8) THEN
6569 C...W+ + W- -> h0
6570           XH=SH/SHP
6571   230     DO 260 JT=1,2
6572             I=MINT(14+JT)
6573             IA=IABS(I)
6574             IF(IA.LE.10) THEN
6575               RVCKM=VINT(180+I)*PYR(0)
6576               DO 240 J=1,MSTP(1)
6577                 IB=2*J-1+MOD(IA,2)
6578                 IPM=(5-ISIGN(1,I))/2
6579                 IDC=J+MDCY(IA,2)+2
6580                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
6581                 MINT(20+JT)=ISIGN(IB,I)
6582                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6583                 IF(RVCKM.LE.0D0) GOTO 250
6584   240         CONTINUE
6585             ELSE
6586               IB=2*((IA+1)/2)-1+MOD(IA,2)
6587               MINT(20+JT)=ISIGN(IB,I)
6588             ENDIF
6589   250       PMQ(JT)=PYMASS(MINT(20+JT))
6590   260     CONTINUE
6591           JT=INT(1.5D0+PYR(0))
6592           ZMIN=2D0*PMQ(JT)/SHPR
6593           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
6594      &    (SHPR*(SHPR-PMQ(3-JT)))
6595           ZMAX=MIN(1D0-XH,ZMAX)
6596           IF(ZMIN.GE.ZMAX) GOTO 230
6597           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
6598           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
6599      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
6600           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
6601           IF(SQC1.LT.1.D-8) GOTO 230
6602           C1=SQRT(SQC1)
6603           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
6604           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6605           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
6606           Z(3-JT)=1D0-XH/(1D0-Z(JT))
6607           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
6608           IF(SQC1.LT.1.D-8) GOTO 230
6609           C1=SQRT(SQC1)
6610           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
6611           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
6612           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
6613           PHIR=PARU(2)*PYR(0)
6614           CPHI=COS(PHIR)
6615           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
6616      &    SQRT(1D0-CTHE(2)**2)*CPHI
6617           Z1=2D0-Z(JT)
6618           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
6619           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
6620           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
6621      &    PMQ(3-JT)**2/SHP))
6622           ZMIN=2D0*PMQ(3-JT)/SHPR
6623           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
6624           ZMAX=MIN(1D0-XH,ZMAX)
6625           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
6626           KCC=22
6627           KFRES=25
6628
6629         ELSEIF(ISUB.EQ.10) THEN
6630 C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
6631           IF(MINT(2).EQ.1) THEN
6632             KCC=22
6633           ELSE
6634 C...W exchange: need to mix flavours according to CKM matrix
6635             DO 280 JT=1,2
6636               I=MINT(14+JT)
6637               IA=IABS(I)
6638               IF(IA.LE.10) THEN
6639                 RVCKM=VINT(180+I)*PYR(0)
6640                 DO 270 J=1,MSTP(1)
6641                   IB=2*J-1+MOD(IA,2)
6642                   IPM=(5-ISIGN(1,I))/2
6643                   IDC=J+MDCY(IA,2)+2
6644                   IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
6645                   MINT(20+JT)=ISIGN(IB,I)
6646                   RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6647                   IF(RVCKM.LE.0D0) GOTO 280
6648   270           CONTINUE
6649               ELSE
6650                 IB=2*((IA+1)/2)-1+MOD(IA,2)
6651                 MINT(20+JT)=ISIGN(IB,I)
6652               ENDIF
6653   280       CONTINUE
6654             KCC=22
6655           ENDIF
6656         ENDIF
6657
6658       ELSEIF(ISUB.LE.20) THEN
6659         IF(ISUB.EQ.11) THEN
6660 C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
6661           KCC=MINT(2)
6662           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
6663
6664         ELSEIF(ISUB.EQ.12) THEN
6665 C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
6666           MINT(21)=ISIGN(KFLF,MINT(15))
6667           MINT(22)=-MINT(21)
6668           KCC=4
6669
6670         ELSEIF(ISUB.EQ.13) THEN
6671 C...f + fbar -> g + g; th arbitrary
6672           MINT(21)=21
6673           MINT(22)=21
6674           KCC=MINT(2)+4
6675
6676         ELSEIF(ISUB.EQ.14) THEN
6677 C...f + fbar -> g + gamma; th arbitrary
6678           IF(PYR(0).GT.0.5D0) JS=2
6679           MINT(20+JS)=21
6680           MINT(23-JS)=22
6681           KCC=17+JS
6682
6683         ELSEIF(ISUB.EQ.15) THEN
6684 C...f + fbar -> g + Z0; th arbitrary
6685           IF(PYR(0).GT.0.5D0) JS=2
6686           MINT(20+JS)=21
6687           MINT(23-JS)=23
6688           KCC=17+JS
6689
6690         ELSEIF(ISUB.EQ.16) THEN
6691 C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6692           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6693           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6694           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6695           MINT(20+JS)=21
6696           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6697           KCC=17+JS
6698
6699         ELSEIF(ISUB.EQ.17) THEN
6700 C...f + fbar -> g + h0; th arbitrary
6701           IF(PYR(0).GT.0.5D0) JS=2
6702           MINT(20+JS)=21
6703           MINT(23-JS)=25
6704           KCC=17+JS
6705
6706         ELSEIF(ISUB.EQ.18) THEN
6707 C...f + fbar -> gamma + gamma; th arbitrary
6708           MINT(21)=22
6709           MINT(22)=22
6710
6711         ELSEIF(ISUB.EQ.19) THEN
6712 C...f + fbar -> gamma + Z0; th arbitrary
6713           IF(PYR(0).GT.0.5D0) JS=2
6714           MINT(20+JS)=22
6715           MINT(23-JS)=23
6716
6717         ELSEIF(ISUB.EQ.20) THEN
6718 C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
6719 C...(p(fbar')-p(W+))**2
6720           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6721           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6722           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6723           MINT(20+JS)=22
6724           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6725         ENDIF
6726
6727       ELSEIF(ISUB.LE.30) THEN
6728         IF(ISUB.EQ.21) THEN
6729 C...f + fbar -> gamma + h0; th arbitrary
6730           IF(PYR(0).GT.0.5D0) JS=2
6731           MINT(20+JS)=22
6732           MINT(23-JS)=25
6733
6734         ELSEIF(ISUB.EQ.22) THEN
6735 C...f + fbar -> Z0 + Z0; th arbitrary
6736           MINT(21)=23
6737           MINT(22)=23
6738
6739         ELSEIF(ISUB.EQ.23) THEN
6740 C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6741           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6742           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6743           IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
6744           MINT(20+JS)=23
6745           MINT(23-JS)=ISIGN(24,KCH1+KCH2)
6746
6747         ELSEIF(ISUB.EQ.24) THEN
6748 C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
6749           IF(PYR(0).GT.0.5D0) JS=2
6750           MINT(20+JS)=23
6751           MINT(23-JS)=KFHIGG
6752
6753         ELSEIF(ISUB.EQ.25) THEN
6754 C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
6755           MINT(21)=-ISIGN(24,MINT(15))
6756           MINT(22)=-MINT(21)
6757
6758         ELSEIF(ISUB.EQ.26) THEN
6759 C...f + fbar' -> W+/- + h0 (or H0, or A0);
6760 C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
6761           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
6762           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
6763           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
6764           MINT(20+JS)=ISIGN(24,KCH1+KCH2)
6765           MINT(23-JS)=KFHIGG
6766
6767         ELSEIF(ISUB.EQ.27) THEN
6768 C...f + fbar -> h0 + h0
6769
6770         ELSEIF(ISUB.EQ.28) THEN
6771 C...f + g -> f + g; th = (p(f)-p(f))**2
6772           KCC=MINT(2)+6
6773           IF(MINT(15).EQ.21) KCC=KCC+2
6774           IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
6775           IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
6776
6777         ELSEIF(ISUB.EQ.29) THEN
6778 C...f + g -> f + gamma; th = (p(f)-p(f))**2
6779           IF(MINT(15).EQ.21) JS=2
6780           MINT(23-JS)=22
6781           KCC=15+JS
6782           KCS=ISIGN(1,MINT(14+JS))
6783
6784         ELSEIF(ISUB.EQ.30) THEN
6785 C...f + g -> f + Z0; th = (p(f)-p(f))**2
6786           IF(MINT(15).EQ.21) JS=2
6787           MINT(23-JS)=23
6788           KCC=15+JS
6789           KCS=ISIGN(1,MINT(14+JS))
6790         ENDIF
6791
6792       ELSEIF(ISUB.LE.40) THEN
6793         IF(ISUB.EQ.31) THEN
6794 C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
6795           IF(MINT(15).EQ.21) JS=2
6796           I=MINT(14+JS)
6797           IA=IABS(I)
6798           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6799           RVCKM=VINT(180+I)*PYR(0)
6800           DO 290 J=1,MSTP(1)
6801             IB=2*J-1+MOD(IA,2)
6802             IPM=(5-ISIGN(1,I))/2
6803             IDC=J+MDCY(IA,2)+2
6804             IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
6805             MINT(20+JS)=ISIGN(IB,I)
6806             RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6807             IF(RVCKM.LE.0D0) GOTO 300
6808   290     CONTINUE
6809   300     KCC=15+JS
6810           KCS=ISIGN(1,MINT(14+JS))
6811
6812         ELSEIF(ISUB.EQ.32) THEN
6813 C...f + g -> f + h0; th = (p(f)-p(f))**2
6814           IF(MINT(15).EQ.21) JS=2
6815           MINT(23-JS)=25
6816           KCC=15+JS
6817           KCS=ISIGN(1,MINT(14+JS))
6818
6819         ELSEIF(ISUB.EQ.33) THEN
6820 C...f + gamma -> f + g; th=(p(f)-p(f))**2
6821           IF(MINT(15).EQ.22) JS=2
6822           MINT(23-JS)=21
6823           KCC=24+JS
6824           KCS=ISIGN(1,MINT(14+JS))
6825
6826         ELSEIF(ISUB.EQ.34) THEN
6827 C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
6828           IF(MINT(15).EQ.22) JS=2
6829           KCC=22
6830           KCS=ISIGN(1,MINT(14+JS))
6831
6832         ELSEIF(ISUB.EQ.35) THEN
6833 C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
6834           IF(MINT(15).EQ.22) JS=2
6835           MINT(23-JS)=23
6836           KCC=22
6837
6838         ELSEIF(ISUB.EQ.36) THEN
6839 C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
6840           IF(MINT(15).EQ.22) JS=2
6841           I=MINT(14+JS)
6842           IA=IABS(I)
6843           MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
6844           IF(IA.LE.10) THEN
6845             RVCKM=VINT(180+I)*PYR(0)
6846             DO 310 J=1,MSTP(1)
6847               IB=2*J-1+MOD(IA,2)
6848               IPM=(5-ISIGN(1,I))/2
6849               IDC=J+MDCY(IA,2)+2
6850               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
6851               MINT(20+JS)=ISIGN(IB,I)
6852               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
6853               IF(RVCKM.LE.0D0) GOTO 320
6854   310       CONTINUE
6855           ELSE
6856             IB=2*((IA+1)/2)-1+MOD(IA,2)
6857             MINT(20+JS)=ISIGN(IB,I)
6858           ENDIF
6859   320     KCC=22
6860
6861         ELSEIF(ISUB.EQ.37) THEN
6862 C...f + gamma -> f + h0
6863
6864         ELSEIF(ISUB.EQ.38) THEN
6865 C...f + Z0 -> f + g
6866
6867         ELSEIF(ISUB.EQ.39) THEN
6868 C...f + Z0 -> f + gamma
6869
6870         ELSEIF(ISUB.EQ.40) THEN
6871 C...f + Z0 -> f + Z0
6872         ENDIF
6873
6874       ELSEIF(ISUB.LE.50) THEN
6875         IF(ISUB.EQ.41) THEN
6876 C...f + Z0 -> f' + W+/-
6877
6878         ELSEIF(ISUB.EQ.42) THEN
6879 C...f + Z0 -> f + h0
6880
6881         ELSEIF(ISUB.EQ.43) THEN
6882 C...f + W+/- -> f' + g
6883
6884         ELSEIF(ISUB.EQ.44) THEN
6885 C...f + W+/- -> f' + gamma
6886
6887         ELSEIF(ISUB.EQ.45) THEN
6888 C...f + W+/- -> f' + Z0
6889
6890         ELSEIF(ISUB.EQ.46) THEN
6891 C...f + W+/- -> f' + W+/-
6892
6893         ELSEIF(ISUB.EQ.47) THEN
6894 C...f + W+/- -> f' + h0
6895
6896         ELSEIF(ISUB.EQ.48) THEN
6897 C...f + h0 -> f + g
6898
6899         ELSEIF(ISUB.EQ.49) THEN
6900 C...f + h0 -> f + gamma
6901
6902         ELSEIF(ISUB.EQ.50) THEN
6903 C...f + h0 -> f + Z0
6904         ENDIF
6905
6906       ELSEIF(ISUB.LE.60) THEN
6907         IF(ISUB.EQ.51) THEN
6908 C...f + h0 -> f' + W+/-
6909
6910         ELSEIF(ISUB.EQ.52) THEN
6911 C...f + h0 -> f + h0
6912
6913         ELSEIF(ISUB.EQ.53) THEN
6914 C...g + g -> f + fbar; th arbitrary
6915           KCS=(-1)**INT(1.5D0+PYR(0))
6916           MINT(21)=ISIGN(KFLF,KCS)
6917           MINT(22)=-MINT(21)
6918           KCC=MINT(2)+10
6919
6920         ELSEIF(ISUB.EQ.54) THEN
6921 C...g + gamma -> f + fbar; th arbitrary
6922           KCS=(-1)**INT(1.5D0+PYR(0))
6923           MINT(21)=ISIGN(KFLF,KCS)
6924           MINT(22)=-MINT(21)
6925           KCC=27
6926           IF(MINT(16).EQ.21) KCC=28
6927
6928         ELSEIF(ISUB.EQ.55) THEN
6929 C...g + Z0 -> f + fbar
6930
6931         ELSEIF(ISUB.EQ.56) THEN
6932 C...g + W+/- -> f + fbar'
6933
6934         ELSEIF(ISUB.EQ.57) THEN
6935 C...g + h0 -> f + fbar
6936
6937         ELSEIF(ISUB.EQ.58) THEN
6938 C...gamma + gamma -> f + fbar; th arbitrary
6939           KCS=(-1)**INT(1.5D0+PYR(0))
6940           MINT(21)=ISIGN(KFLF,KCS)
6941           MINT(22)=-MINT(21)
6942           KCC=21
6943
6944         ELSEIF(ISUB.EQ.59) THEN
6945 C...gamma + Z0 -> f + fbar
6946
6947         ELSEIF(ISUB.EQ.60) THEN
6948 C...gamma + W+/- -> f + fbar'
6949         ENDIF
6950
6951       ELSEIF(ISUB.LE.70) THEN
6952         IF(ISUB.EQ.61) THEN
6953 C...gamma + h0 -> f + fbar
6954
6955         ELSEIF(ISUB.EQ.62) THEN
6956 C...Z0 + Z0 -> f + fbar
6957
6958         ELSEIF(ISUB.EQ.63) THEN
6959 C...Z0 + W+/- -> f + fbar'
6960
6961         ELSEIF(ISUB.EQ.64) THEN
6962 C...Z0 + h0 -> f + fbar
6963
6964         ELSEIF(ISUB.EQ.65) THEN
6965 C...W+ + W- -> f + fbar
6966
6967         ELSEIF(ISUB.EQ.66) THEN
6968 C...W+/- + h0 -> f + fbar'
6969
6970         ELSEIF(ISUB.EQ.67) THEN
6971 C...h0 + h0 -> f + fbar
6972
6973         ELSEIF(ISUB.EQ.68) THEN
6974 C...g + g -> g + g; th arbitrary
6975           KCC=MINT(2)+12
6976           KCS=(-1)**INT(1.5D0+PYR(0))
6977
6978         ELSEIF(ISUB.EQ.69) THEN
6979 C...gamma + gamma -> W+ + W-; th arbitrary
6980           MINT(21)=24
6981           MINT(22)=-24
6982           KCC=21
6983
6984         ELSEIF(ISUB.EQ.70) THEN
6985 C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
6986           IF(MINT(15).EQ.22) MINT(21)=23
6987           IF(MINT(16).EQ.22) MINT(22)=23
6988           KCC=21
6989         ENDIF
6990
6991       ELSEIF(ISUB.LE.80) THEN
6992         IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
6993 C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
6994           XH=SH/SHP
6995           MINT(21)=MINT(15)
6996           MINT(22)=MINT(16)
6997           PMQ(1)=PYMASS(MINT(21))
6998           PMQ(2)=PYMASS(MINT(22))
6999   330     JT=INT(1.5D0+PYR(0))
7000           ZMIN=2D0*PMQ(JT)/SHPR
7001           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7002      &    (SHPR*(SHPR-PMQ(3-JT)))
7003           ZMAX=MIN(1D0-XH,ZMAX)
7004           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7005           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7006      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
7007           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7008           IF(SQC1.LT.1.D-8) GOTO 330
7009           C1=SQRT(SQC1)
7010           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7011           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7012           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7013           Z(3-JT)=1D0-XH/(1D0-Z(JT))
7014           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7015           IF(SQC1.LT.1.D-8) GOTO 330
7016           C1=SQRT(SQC1)
7017           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7018           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7019           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7020           PHIR=PARU(2)*PYR(0)
7021           CPHI=COS(PHIR)
7022           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7023      &    SQRT(1D0-CTHE(2)**2)*CPHI
7024           Z1=2D0-Z(JT)
7025           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7026           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7027           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7028      &    PMQ(3-JT)**2/SHP))
7029           ZMIN=2D0*PMQ(3-JT)/SHPR
7030           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7031           ZMAX=MIN(1D0-XH,ZMAX)
7032           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
7033           KCC=22
7034
7035         ELSEIF(ISUB.EQ.73) THEN
7036 C...Z0 + W+/- -> Z0 + W+/-
7037           JS=MINT(2)
7038           XH=SH/SHP
7039   340     JT=3-MINT(2)
7040           I=MINT(14+JT)
7041           IA=IABS(I)
7042           IF(IA.LE.10) THEN
7043             RVCKM=VINT(180+I)*PYR(0)
7044             DO 350 J=1,MSTP(1)
7045               IB=2*J-1+MOD(IA,2)
7046               IPM=(5-ISIGN(1,I))/2
7047               IDC=J+MDCY(IA,2)+2
7048               IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
7049               MINT(20+JT)=ISIGN(IB,I)
7050               RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7051               IF(RVCKM.LE.0D0) GOTO 360
7052   350       CONTINUE
7053           ELSE
7054             IB=2*((IA+1)/2)-1+MOD(IA,2)
7055             MINT(20+JT)=ISIGN(IB,I)
7056           ENDIF
7057   360     PMQ(JT)=PYMASS(MINT(20+JT))
7058           MINT(23-JT)=MINT(17-JT)
7059           PMQ(3-JT)=PYMASS(MINT(23-JT))
7060           JT=INT(1.5D0+PYR(0))
7061           ZMIN=2D0*PMQ(JT)/SHPR
7062           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7063      &    (SHPR*(SHPR-PMQ(3-JT)))
7064           ZMAX=MIN(1D0-XH,ZMAX)
7065           IF(ZMIN.GE.ZMAX) GOTO 340
7066           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7067           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7068      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
7069           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7070           IF(SQC1.LT.1.D-8) GOTO 340
7071           C1=SQRT(SQC1)
7072           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7073           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7074           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7075           Z(3-JT)=1D0-XH/(1D0-Z(JT))
7076           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7077           IF(SQC1.LT.1.D-8) GOTO 340
7078           C1=SQRT(SQC1)
7079           C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7080           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7081           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7082           PHIR=PARU(2)*PYR(0)
7083           CPHI=COS(PHIR)
7084           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7085      &    SQRT(1D0-CTHE(2)**2)*CPHI
7086           Z1=2D0-Z(JT)
7087           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7088           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7089           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7090      &    PMQ(3-JT)**2/SHP))
7091           ZMIN=2D0*PMQ(3-JT)/SHPR
7092           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7093           ZMAX=MIN(1D0-XH,ZMAX)
7094           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
7095           KCC=22
7096
7097         ELSEIF(ISUB.EQ.74) THEN
7098 C...Z0 + h0 -> Z0 + h0
7099
7100         ELSEIF(ISUB.EQ.75) THEN
7101 C...W+ + W- -> gamma + gamma
7102
7103         ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
7104 C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
7105           XH=SH/SHP
7106   370     DO 400 JT=1,2
7107             I=MINT(14+JT)
7108             IA=IABS(I)
7109             IF(IA.LE.10) THEN
7110               RVCKM=VINT(180+I)*PYR(0)
7111               DO 380 J=1,MSTP(1)
7112                 IB=2*J-1+MOD(IA,2)
7113                 IPM=(5-ISIGN(1,I))/2
7114                 IDC=J+MDCY(IA,2)+2
7115                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
7116                 MINT(20+JT)=ISIGN(IB,I)
7117                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7118                 IF(RVCKM.LE.0D0) GOTO 390
7119   380         CONTINUE
7120             ELSE
7121               IB=2*((IA+1)/2)-1+MOD(IA,2)
7122               MINT(20+JT)=ISIGN(IB,I)
7123             ENDIF
7124   390       PMQ(JT)=PYMASS(MINT(20+JT))
7125   400     CONTINUE
7126           JT=INT(1.5D0+PYR(0))
7127           ZMIN=2D0*PMQ(JT)/SHPR
7128           ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
7129      &    (SHPR*(SHPR-PMQ(3-JT)))
7130           ZMAX=MIN(1D0-XH,ZMAX)
7131           IF(ZMIN.GE.ZMAX) GOTO 370
7132           Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
7133           IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
7134      &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
7135           SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
7136           IF(SQC1.LT.1.D-8) GOTO 370
7137           C1=SQRT(SQC1)
7138           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
7139           CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7140           CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
7141           Z(3-JT)=1D0-XH/(1D0-Z(JT))
7142           SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
7143           IF(SQC1.LT.1.D-8) GOTO 370
7144           C1=SQRT(SQC1)
7145           C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
7146           CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
7147           CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
7148           PHIR=PARU(2)*PYR(0)
7149           CPHI=COS(PHIR)
7150           ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
7151      &    SQRT(1D0-CTHE(2)**2)*CPHI
7152           Z1=2D0-Z(JT)
7153           Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
7154           Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
7155           Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
7156      &    PMQ(3-JT)**2/SHP))
7157           ZMIN=2D0*PMQ(3-JT)/SHPR
7158           ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
7159           ZMAX=MIN(1D0-XH,ZMAX)
7160           IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
7161           KCC=22
7162
7163         ELSEIF(ISUB.EQ.78) THEN
7164 C...W+/- + h0 -> W+/- + h0
7165
7166         ELSEIF(ISUB.EQ.79) THEN
7167 C...h0 + h0 -> h0 + h0
7168
7169         ELSEIF(ISUB.EQ.80) THEN
7170 C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
7171           IF(MINT(15).EQ.22) JS=2
7172           I=MINT(14+JS)
7173           IA=IABS(I)
7174           MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
7175           IB=3-IA
7176           MINT(20+JS)=ISIGN(IB,I)
7177           KCC=22
7178         ENDIF
7179
7180       ELSEIF(ISUB.LE.90) THEN
7181         IF(ISUB.EQ.81) THEN
7182 C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
7183           MINT(21)=ISIGN(MINT(55),MINT(15))
7184           MINT(22)=-MINT(21)
7185           KCC=4
7186
7187         ELSEIF(ISUB.EQ.82) THEN
7188 C...g + g -> Q + Qbar; th arbitrary
7189           KCS=(-1)**INT(1.5D0+PYR(0))
7190           MINT(21)=ISIGN(MINT(55),KCS)
7191           MINT(22)=-MINT(21)
7192           KCC=MINT(2)+10
7193
7194         ELSEIF(ISUB.EQ.83) THEN
7195 C...f + q -> f' + Q; th = (p(f) - p(f'))**2
7196           KFOLD=MINT(16)
7197           IF(MINT(2).EQ.2) KFOLD=MINT(15)
7198           KFAOLD=IABS(KFOLD)
7199           IF(KFAOLD.GT.10) THEN
7200             KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
7201           ELSE
7202             RCKM=VINT(180+KFOLD)*PYR(0)
7203             IPM=(5-ISIGN(1,KFOLD))/2
7204             KFANEW=-MOD(KFAOLD+1,2)
7205   410       KFANEW=KFANEW+2
7206             IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
7207             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
7208               IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
7209      &        VCKM(KFAOLD/2,(KFANEW+1)/2)
7210               IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
7211      &        VCKM(KFANEW/2,(KFAOLD+1)/2)
7212             ENDIF
7213             IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
7214           ENDIF
7215           IF(MINT(2).EQ.1) THEN
7216             MINT(21)=ISIGN(MINT(55),MINT(15))
7217             MINT(22)=ISIGN(KFANEW,MINT(16))
7218           ELSE
7219             MINT(21)=ISIGN(KFANEW,MINT(15))
7220             MINT(22)=ISIGN(MINT(55),MINT(16))
7221             JS=2
7222           ENDIF
7223           KCC=22
7224
7225         ELSEIF(ISUB.EQ.84) THEN
7226 C...g + gamma -> Q + Qbar; th arbitary
7227           KCS=(-1)**INT(1.5D0+PYR(0))
7228           MINT(21)=ISIGN(MINT(55),KCS)
7229           MINT(22)=-MINT(21)
7230           KCC=27
7231           IF(MINT(16).EQ.21) KCC=28
7232
7233         ELSEIF(ISUB.EQ.85) THEN
7234 C...gamma + gamma -> F + Fbar; th arbitary
7235           KCS=(-1)**INT(1.5D0+PYR(0))
7236           MINT(21)=ISIGN(MINT(56),KCS)
7237           MINT(22)=-MINT(21)
7238           KCC=21
7239
7240         ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
7241 C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
7242           MINT(21)=KFPR(ISUB,1)
7243           MINT(22)=KFPR(ISUB,2)
7244           KCC=24
7245           KCS=(-1)**INT(1.5D0+PYR(0))
7246         ENDIF
7247
7248       ELSEIF(ISUB.LE.100) THEN
7249         IF(ISUB.EQ.95) THEN
7250 C...Low-pT ( = energyless g + g -> g + g)
7251           KCC=MINT(2)+12
7252           KCS=(-1)**INT(1.5D0+PYR(0))
7253
7254         ELSEIF(ISUB.EQ.96) THEN
7255 C...Multiple interactions (should be reassigned to QCD process)
7256         ENDIF
7257
7258       ELSEIF(ISUB.LE.110) THEN
7259         IF(ISUB.EQ.101) THEN
7260 C...g + g -> gamma*/Z0
7261           KCC=21
7262           KFRES=22
7263
7264         ELSEIF(ISUB.EQ.102) THEN
7265 C...g + g -> h0 (or H0, or A0)
7266           KCC=21
7267           KFRES=KFHIGG
7268
7269         ELSEIF(ISUB.EQ.103) THEN
7270 C...gamma + gamma -> h0 (or H0, or A0)
7271           KCC=21
7272           KFRES=KFHIGG
7273
7274         ELSEIF(ISUB.EQ.106) THEN
7275 C...g + g -> J/Psi + gamma
7276           MINT(21)=KFPR(ISUB,1)
7277           MINT(22)=KFPR(ISUB,2)
7278           KCC=21
7279
7280         ELSEIF(ISUB.EQ.107) THEN
7281 C...g + gamma -> J/Psi + g
7282           MINT(21)=KFPR(ISUB,1)
7283           MINT(22)=KFPR(ISUB,2)
7284           KCC=22
7285           IF(MINT(16).EQ.22) KCC=33
7286
7287         ELSEIF(ISUB.EQ.108) THEN
7288 C...gamma + gamma -> J/Psi + gamma
7289           MINT(21)=KFPR(ISUB,1)
7290           MINT(22)=KFPR(ISUB,2)
7291
7292         ELSEIF(ISUB.EQ.110) THEN
7293 C...f + fbar -> gamma + h0; th arbitrary
7294           IF(PYR(0).GT.0.5D0) JS=2
7295           MINT(20+JS)=22
7296           MINT(23-JS)=KFHIGG
7297         ENDIF
7298
7299       ELSEIF(ISUB.LE.120) THEN
7300         IF(ISUB.EQ.111) THEN
7301 C...f + fbar -> g + h0; th arbitrary
7302           IF(PYR(0).GT.0.5D0) JS=2
7303           MINT(20+JS)=21
7304           MINT(23-JS)=25
7305           KCC=17+JS
7306
7307         ELSEIF(ISUB.EQ.112) THEN
7308 C...f + g -> f + h0; th = (p(f) - p(f))**2
7309           IF(MINT(15).EQ.21) JS=2
7310           MINT(23-JS)=25
7311           KCC=15+JS
7312           KCS=ISIGN(1,MINT(14+JS))
7313
7314         ELSEIF(ISUB.EQ.113) THEN
7315 C...g + g -> g + h0; th arbitrary
7316           IF(PYR(0).GT.0.5D0) JS=2
7317           MINT(23-JS)=25
7318           KCC=22+JS
7319           KCS=(-1)**INT(1.5D0+PYR(0))
7320
7321         ELSEIF(ISUB.EQ.114) THEN
7322 C...g + g -> gamma + gamma; th arbitrary
7323           IF(PYR(0).GT.0.5D0) JS=2
7324           MINT(21)=22
7325           MINT(22)=22
7326           KCC=21
7327
7328         ELSEIF(ISUB.EQ.115) THEN
7329 C...g + g -> g + gamma; th arbitrary
7330           IF(PYR(0).GT.0.5D0) JS=2
7331           MINT(23-JS)=22
7332           KCC=22+JS
7333           KCS=(-1)**INT(1.5D0+PYR(0))
7334
7335         ELSEIF(ISUB.EQ.116) THEN
7336 C...g + g -> gamma + Z0
7337
7338         ELSEIF(ISUB.EQ.117) THEN
7339 C...g + g -> Z0 + Z0
7340
7341         ELSEIF(ISUB.EQ.118) THEN
7342 C...g + g -> W+ + W-
7343         ENDIF
7344
7345       ELSEIF(ISUB.LE.140) THEN
7346         IF(ISUB.EQ.121) THEN
7347 C...g + g -> Q + Qbar + h0
7348           KCS=(-1)**INT(1.5D0+PYR(0))
7349           MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
7350           MINT(22)=-MINT(21)
7351           KCC=11+INT(0.5D0+PYR(0))
7352           KFRES=KFHIGG
7353
7354         ELSEIF(ISUB.EQ.122) THEN
7355 C...q + qbar -> Q + Qbar + h0
7356           MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
7357           MINT(22)=-MINT(21)
7358           KCC=4
7359           KFRES=KFHIGG
7360
7361         ELSEIF(ISUB.EQ.123) THEN
7362 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
7363 C...inner process)
7364           KCC=22
7365           KFRES=KFHIGG
7366
7367         ELSEIF(ISUB.EQ.124) THEN
7368 C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
7369 C...inner process)
7370           DO 430 JT=1,2
7371             I=MINT(14+JT)
7372             IA=IABS(I)
7373             IF(IA.LE.10) THEN
7374               RVCKM=VINT(180+I)*PYR(0)
7375               DO 420 J=1,MSTP(1)
7376                 IB=2*J-1+MOD(IA,2)
7377                 IPM=(5-ISIGN(1,I))/2
7378                 IDC=J+MDCY(IA,2)+2
7379                 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
7380                 MINT(20+JT)=ISIGN(IB,I)
7381                 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
7382                 IF(RVCKM.LE.0D0) GOTO 430
7383   420         CONTINUE
7384             ELSE
7385               IB=2*((IA+1)/2)-1+MOD(IA,2)
7386               MINT(20+JT)=ISIGN(IB,I)
7387             ENDIF
7388   430     CONTINUE
7389           KCC=22
7390           KFRES=KFHIGG
7391
7392         ELSEIF(ISUB.EQ.131) THEN
7393 C...g + g -> Z0 + q + qbar
7394         ENDIF
7395
7396       ELSEIF(ISUB.LE.160) THEN
7397         IF(ISUB.EQ.141) THEN
7398 C...f + fbar -> gamma*/Z0/Z'0
7399           KFRES=32
7400
7401         ELSEIF(ISUB.EQ.142) THEN
7402 C...f + fbar' -> W'+/-
7403           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7404           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7405           KFRES=ISIGN(34,KCH1+KCH2)
7406
7407         ELSEIF(ISUB.EQ.143) THEN
7408 C...f + fbar' -> H+/-
7409           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7410           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7411           KFRES=ISIGN(37,KCH1+KCH2)
7412
7413         ELSEIF(ISUB.EQ.144) THEN
7414 C...f + fbar' -> R
7415           KFRES=ISIGN(40,MINT(15)+MINT(16))
7416
7417         ELSEIF(ISUB.EQ.145) THEN
7418 C...q + l -> LQ (leptoquark)
7419           IF(IABS(MINT(16)).LE.8) JS=2
7420           KFRES=ISIGN(39,MINT(14+JS))
7421           KCC=28+JS
7422           KCS=ISIGN(1,MINT(14+JS))
7423
7424         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
7425 C...q + g -> q* (excited quark)
7426           IF(MINT(15).EQ.21) JS=2
7427           KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
7428           KCC=30+JS
7429           KCS=ISIGN(1,MINT(14+JS))
7430
7431         ELSEIF(ISUB.EQ.149) THEN
7432 C...g + g -> eta_techni
7433           KFRES=38
7434           KCC=23
7435           KCS=(-1)**INT(1.5D0+PYR(0))
7436         ENDIF
7437
7438       ELSEIF(ISUB.LE.200) THEN
7439         IF(ISUB.EQ.161) THEN
7440 C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
7441           IF(MINT(15).EQ.21) JS=2
7442           I=MINT(14+JS)
7443           IA=IABS(I)
7444           MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
7445           IB=IA+MOD(IA,2)-MOD(IA+1,2)
7446           MINT(20+JS)=ISIGN(IB,I)
7447           KCC=15+JS
7448           KCS=ISIGN(1,MINT(14+JS))
7449
7450         ELSEIF(ISUB.EQ.162) THEN
7451 C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
7452           IF(MINT(15).EQ.21) JS=2
7453           MINT(20+JS)=ISIGN(39,MINT(14+JS))
7454           KFLQL=KFDP(MDCY(39,2),2)
7455           MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
7456           KCC=15+JS
7457           KCS=ISIGN(1,MINT(14+JS))
7458
7459         ELSEIF(ISUB.EQ.163) THEN
7460 C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
7461           KCS=(-1)**INT(1.5D0+PYR(0))
7462           MINT(21)=ISIGN(39,KCS)
7463           MINT(22)=-MINT(21)
7464           KCC=MINT(2)+10
7465
7466         ELSEIF(ISUB.EQ.164) THEN
7467 C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
7468           MINT(21)=ISIGN(39,MINT(15))
7469           MINT(22)=-MINT(21)
7470           KCC=4
7471
7472         ELSEIF(ISUB.EQ.165) THEN
7473 C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
7474           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7475           MINT(22)=-MINT(21)
7476
7477         ELSEIF(ISUB.EQ.166) THEN
7478 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
7479           IF(MOD(MINT(15),2).EQ.0) THEN
7480             MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
7481             MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
7482           ELSE
7483             MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7484             MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
7485           ENDIF
7486
7487         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
7488 C...q + q' -> q" + q* (excited quark)
7489           KFQSTR=KFPR(ISUB,2)
7490           KFQEXC=MOD(KFQSTR,KEXCIT)
7491           JS=MINT(2)
7492           MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
7493           IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
7494      &    MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
7495           KCC=22
7496
7497         ELSEIF(ISUB.EQ.191) THEN
7498 C...f + fbar -> rho_tech0.
7499           KFRES=54
7500
7501         ELSEIF(ISUB.EQ.192) THEN
7502 C...f + fbar' -> rho_tech+/-
7503           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7504           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7505           KFRES=ISIGN(55,KCH1+KCH2)
7506
7507         ELSEIF(ISUB.EQ.193) THEN
7508 C...f + fbar -> omega_tech0.
7509           KFRES=56
7510
7511         ELSEIF(ISUB.EQ.194) THEN
7512 C...f + fbar -> f' + fbar' via mixture of s-channel
7513 C...rho_tech and omega_tech; th=(p(f)-p(f'))**2
7514           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
7515           MINT(22)=-MINT(21)
7516          ENDIF
7517
7518 CMRENNA++
7519       ELSEIF(ISUB.LE.215) THEN
7520         IF(ISUB.EQ.201) THEN
7521 C...f + fbar -> ~e_L + ~e_Lbar
7522           MINT(21)=ISIGN(KSUSY1+11,KCS)
7523           MINT(22)=-MINT(21)
7524
7525         ELSEIF(ISUB.EQ.202) THEN
7526 C...f + fbar -> ~e_R + ~e_Rbar
7527           MINT(21)=ISIGN(KSUSY2+11,KCS)
7528           MINT(22)=-MINT(21)
7529
7530         ELSEIF(ISUB.EQ.203) THEN
7531 C...f + fbar -> ~e_R + ~e_Lbar
7532           KCS=1
7533           IF(MINT(2).EQ.2) KCS=-1
7534           MINT(21)=ISIGN(KSUSY1+11,KCS)
7535           MINT(22)=-ISIGN(KSUSY2+11,KCS)
7536
7537         ELSEIF(ISUB.EQ.204) THEN
7538 C...f + fbar -> ~mu_L + ~mu_Lbar
7539           MINT(21)=ISIGN(KSUSY1+13,KCS)
7540           MINT(22)=-MINT(21)
7541
7542         ELSEIF(ISUB.EQ.205) THEN
7543 C...f + fbar -> ~mu_R + ~mu_Rbar
7544           MINT(21)=ISIGN(KSUSY2+13,KCS)
7545           MINT(22)=-MINT(21)
7546
7547         ELSEIF(ISUB.EQ.206) THEN
7548 C...f + fbar -> ~mu_L + ~mu_Rbar
7549           KCS=1
7550           IF(MINT(2).EQ.2) KCS=-1
7551           MINT(21)=ISIGN(KSUSY1+13,KCS)
7552           MINT(22)=-ISIGN(KSUSY2+13,KCS)
7553
7554         ELSEIF(ISUB.EQ.207) THEN
7555 C...f + fbar -> ~tau_1 + ~tau_1bar
7556           MINT(21)=ISIGN(KSUSY1+15,KCS)
7557           MINT(22)=-MINT(21)
7558
7559         ELSEIF(ISUB.EQ.208) THEN
7560 C...f + fbar -> ~tau_2 + ~tau_2bar
7561           MINT(21)=ISIGN(KSUSY2+15,KCS)
7562           MINT(22)=-MINT(21)
7563
7564         ELSEIF(ISUB.EQ.209) THEN
7565 C...f + fbar -> ~tau_1 + ~tau_2bar
7566           KCS=1
7567           IF(MINT(2).EQ.2) KCS=-1
7568           MINT(21)=ISIGN(KSUSY1+15,KCS)
7569           MINT(22)=-ISIGN(KSUSY2+15,KCS)
7570
7571         ELSEIF(ISUB.EQ.210) THEN
7572 C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
7573           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7574           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7575           MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
7576           MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
7577
7578         ELSEIF(ISUB.EQ.211) THEN
7579 C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
7580           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7581           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7582           MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
7583           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7584
7585         ELSEIF(ISUB.EQ.212) THEN
7586 C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
7587           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7588           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7589           MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
7590           MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
7591
7592         ELSEIF(ISUB.EQ.213) THEN
7593 C...f + fbar -> ~nul + ~nulbar
7594           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7595           MINT(22)=-MINT(21)
7596
7597         ELSEIF(ISUB.EQ.214) THEN
7598 C...f + fbar -> ~nutau + ~nutaubar
7599           MINT(21)=ISIGN(KSUSY1+16,KCS)
7600           MINT(22)=-MINT(21)
7601         ENDIF
7602
7603       ELSEIF(ISUB.LE.225) THEN
7604         IF(ISUB.EQ.216) THEN
7605 C...f + fbar -> ~chi01 + ~chi01
7606           MINT(21)=KSUSY1+22
7607           MINT(22)=KSUSY1+22
7608
7609         ELSEIF(ISUB.EQ.217) THEN
7610 C...f + fbar -> ~chi02 + ~chi02
7611           MINT(21)=KSUSY1+23
7612           MINT(22)=KSUSY1+23
7613
7614         ELSEIF(ISUB.EQ.218 ) THEN
7615 C...f + fbar -> ~chi03 + ~chi03
7616           MINT(21)=KSUSY1+25
7617           MINT(22)=KSUSY1+25
7618
7619         ELSEIF(ISUB.EQ.219 ) THEN
7620 C...f + fbar -> ~chi04 + ~chi04
7621           MINT(21)=KSUSY1+35
7622           MINT(22)=KSUSY1+35
7623
7624         ELSEIF(ISUB.EQ.220 ) THEN
7625 C...f + fbar -> ~chi01 + ~chi02
7626           IF(PYR(0).GT.0.5D0) JS=2
7627           MINT(20+JS)=KSUSY1+22
7628           MINT(23-JS)=KSUSY1+23
7629
7630         ELSEIF(ISUB.EQ.221 ) THEN
7631 C...f + fbar -> ~chi01 + ~chi03
7632           IF(PYR(0).GT.0.5D0) JS=2
7633           MINT(20+JS)=KSUSY1+22
7634           MINT(23-JS)=KSUSY1+25
7635
7636         ELSEIF(ISUB.EQ.222) THEN
7637 C...f + fbar -> ~chi01 + ~chi04
7638           IF(PYR(0).GT.0.5D0) JS=2
7639           MINT(20+JS)=KSUSY1+22
7640           MINT(23-JS)=KSUSY1+35
7641
7642         ELSEIF(ISUB.EQ.223) THEN
7643 C...f + fbar -> ~chi02 + ~chi03
7644           IF(PYR(0).GT.0.5D0) JS=2
7645           MINT(20+JS)=KSUSY1+23
7646           MINT(23-JS)=KSUSY1+25
7647
7648         ELSEIF(ISUB.EQ.224) THEN
7649 C...f + fbar -> ~chi02 + ~chi04
7650           IF(PYR(0).GT.0.5D0) JS=2
7651           MINT(20+JS)=KSUSY1+23
7652           MINT(23-JS)=KSUSY1+35
7653
7654         ELSEIF(ISUB.EQ.225) THEN
7655 C...f + fbar -> ~chi03 + ~chi04
7656           IF(PYR(0).GT.0.5D0) JS=2
7657           MINT(20+JS)=KSUSY1+25
7658           MINT(23-JS)=KSUSY1+35
7659         ENDIF
7660
7661       ELSEIF(ISUB.LE.236) THEN
7662         IF(ISUB.EQ.226) THEN
7663 C...f + fbar -> ~chi+-1 + ~chi-+1
7664 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
7665           MINT(21)=ISIGN(KSUSY1+24,MINT(15))
7666           MINT(22)=-MINT(21)
7667
7668         ELSEIF(ISUB.EQ.227) THEN
7669 C...f + fbar -> ~chi+-2 + ~chi-+2
7670           MINT(21)=ISIGN(KSUSY1+37,MINT(15))
7671           MINT(22)=-MINT(21)
7672
7673         ELSEIF(ISUB.EQ.228) THEN
7674 C...f + fbar -> ~chi+-1 + ~chi-+2
7675 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
7676 C...js=1 if pyr<.5, js=2 if pyr>.5
7677 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
7678 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
7679 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
7680 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
7681           KCH1=ISIGN(1,MINT(15))
7682           KCH2=INT(1-KCH1)/2
7683           IF(MINT(2).EQ.1) THEN
7684             MINT(22-KCH2)= -(KSUSY1+24)
7685             MINT(21+KCH2)= KSUSY1+37
7686             IF(KCH2.EQ.0) JS=2
7687           ELSE
7688             MINT(21+KCH2)= KSUSY1+24
7689             MINT(22-KCH2)= -(KSUSY1+37)
7690             IF(KCH2.EQ.1) JS=2
7691           ENDIF
7692
7693         ELSEIF(ISUB.EQ.229) THEN
7694 C...q + qbar' -> ~chi01 + ~chi+-1
7695 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
7696           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7697           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7698 C...CHECK THIS
7699           IF(MOD(MINT(15),2).NE.0) JS=2
7700           MINT(20+JS)=KSUSY1+22
7701           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7702
7703         ELSEIF(ISUB.EQ.230) THEN
7704 C...q + qbar' -> ~chi02 + ~chi+-1
7705           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7706           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7707           IF(MOD(MINT(15),2).NE.0) JS=2
7708           MINT(20+JS)=KSUSY1+23
7709           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7710
7711         ELSEIF(ISUB.EQ.231) THEN
7712 C...q + qbar' -> ~chi03 + ~chi+-1
7713           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7714           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7715           IF(MOD(MINT(15),2).NE.0) JS=2
7716           MINT(20+JS)=KSUSY1+25
7717           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7718
7719         ELSEIF(ISUB.EQ.232) THEN
7720 C...q + qbar' -> ~chi04 + ~chi+-1
7721           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7722           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7723           IF(MOD(MINT(15),2).NE.0) JS=2
7724           MINT(20+JS)=KSUSY1+35
7725           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7726
7727         ELSEIF(ISUB.EQ.233) THEN
7728 C...q + qbar' -> ~chi01 + ~chi+-2
7729           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7730           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7731           IF(MOD(MINT(15),2).NE.0) JS=2
7732           MINT(20+JS)=KSUSY1+22
7733           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7734
7735         ELSEIF(ISUB.EQ.234) THEN
7736 C...q + qbar' -> ~chi02 + ~chi+-2
7737           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7738           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7739           IF(MOD(MINT(15),2).NE.0) JS=2
7740           MINT(20+JS)=KSUSY1+23
7741           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7742
7743         ELSEIF(ISUB.EQ.235) THEN
7744 C...q + qbar' -> ~chi03 + ~chi+-2
7745           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7746           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7747           IF(MOD(MINT(15),2).NE.0) JS=2
7748           MINT(20+JS)=KSUSY1+25
7749           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7750
7751         ELSEIF(ISUB.EQ.236) THEN
7752 C...q + qbar' -> ~chi04 + ~chi+-2
7753           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7754           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7755           IF(MOD(MINT(15),2).NE.0) JS=2
7756           MINT(20+JS)=KSUSY1+35
7757           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7758         ENDIF
7759
7760       ELSEIF(ISUB.LE.245) THEN
7761         IF(ISUB.EQ.237) THEN
7762 C...q + qbar -> ~chi01 + ~g
7763 C...th arbitrary
7764           IF(PYR(0).GT.0.5D0) JS=2
7765           MINT(20+JS)=KSUSY1+21
7766           MINT(23-JS)=KSUSY1+22
7767           KCC=17+JS
7768
7769         ELSEIF(ISUB.EQ.238) THEN
7770 C...q + qbar -> ~chi02 + ~g
7771 C...th arbitrary
7772           IF(PYR(0).GT.0.5D0) JS=2
7773           MINT(20+JS)=KSUSY1+21
7774           MINT(23-JS)=KSUSY1+23
7775           KCC=17+JS
7776
7777         ELSEIF(ISUB.EQ.239) THEN
7778 C...q + qbar -> ~chi03 + ~g
7779 C...th arbitrary
7780           IF(PYR(0).GT.0.5D0) JS=2
7781           MINT(20+JS)=KSUSY1+21
7782           MINT(23-JS)=KSUSY1+25
7783           KCC=17+JS
7784
7785         ELSEIF(ISUB.EQ.240) THEN
7786 C...q + qbar -> ~chi04 + ~g
7787 C...th arbitrary
7788           IF(PYR(0).GT.0.5D0) JS=2
7789           MINT(20+JS)=KSUSY1+21
7790           MINT(23-JS)=KSUSY1+35
7791           KCC=17+JS
7792
7793         ELSEIF(ISUB.EQ.241) THEN
7794 C...q + qbar' -> ~chi+-1 + ~g
7795 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7796 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7797 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7798 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7799 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7800           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7801           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7802           JS=1
7803           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7804           MINT(20+JS)=KSUSY1+21
7805           MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
7806           KCC=17+JS
7807
7808         ELSEIF(ISUB.EQ.242) THEN
7809 C...q + qbar' -> ~chi+-2 + ~g
7810 C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
7811 C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
7812 C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
7813 C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
7814 C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
7815           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
7816           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
7817           JS=1
7818           IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
7819           MINT(20+JS)=KSUSY1+21
7820           MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
7821           KCC=17+JS
7822
7823         ELSEIF(ISUB.EQ.243) THEN
7824 C...q + qbar -> ~g + ~g ; th arbitrary
7825           MINT(21)=KSUSY1+21
7826           MINT(22)=KSUSY1+21
7827           KCC=MINT(2)+4
7828
7829         ELSEIF(ISUB.EQ.244) THEN
7830 C...g + g -> ~g + ~g ; th arbitrary
7831           KCC=MINT(2)+12
7832           KCS=(-1)**INT(1.5D0+PYR(0))
7833           MINT(21)=KSUSY1+21
7834           MINT(22)=KSUSY1+21
7835         ENDIF
7836
7837       ELSEIF(ISUB.LE.260) THEN
7838         IF(ISUB.EQ.246) THEN
7839 C...qj + g -> ~qj_L + ~chi01
7840           IF(MINT(15).EQ.21) JS=2
7841           I=MINT(14+JS)
7842           IA=IABS(I)
7843           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7844           MINT(23-JS)=KSUSY1+22
7845           KCC=15+JS
7846           KCS=ISIGN(1,MINT(14+JS))
7847
7848         ELSEIF(ISUB.EQ.247) THEN
7849 C...qj + g -> ~qj_R + ~chi01
7850           IF(MINT(15).EQ.21) JS=2
7851           I=MINT(14+JS)
7852           IA=IABS(I)
7853           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7854           MINT(23-JS)=KSUSY1+22
7855           KCC=15+JS
7856           KCS=ISIGN(1,MINT(14+JS))
7857
7858         ELSEIF(ISUB.EQ.248) THEN
7859 C...qj + g -> ~qj_L + ~chi02
7860           IF(MINT(15).EQ.21) JS=2
7861           I=MINT(14+JS)
7862           IA=IABS(I)
7863           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7864           MINT(23-JS)=KSUSY1+23
7865           KCC=15+JS
7866           KCS=ISIGN(1,MINT(14+JS))
7867
7868         ELSEIF(ISUB.EQ.249) THEN
7869 C...qj + g -> ~qj_R + ~chi02
7870           IF(MINT(15).EQ.21) JS=2
7871           I=MINT(14+JS)
7872           IA=IABS(I)
7873           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7874           MINT(23-JS)=KSUSY1+23
7875           KCC=15+JS
7876           KCS=ISIGN(1,MINT(14+JS))
7877
7878         ELSEIF(ISUB.EQ.250) THEN
7879 C...qj + g -> ~qj_L + ~chi03
7880           IF(MINT(15).EQ.21) JS=2
7881           I=MINT(14+JS)
7882           IA=IABS(I)
7883           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7884           MINT(23-JS)=KSUSY1+25
7885           KCC=15+JS
7886           KCS=ISIGN(1,MINT(14+JS))
7887
7888         ELSEIF(ISUB.EQ.251) THEN
7889 C...qj + g -> ~qj_R + ~chi03
7890           IF(MINT(15).EQ.21) JS=2
7891           I=MINT(14+JS)
7892           IA=IABS(I)
7893           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7894           MINT(23-JS)=KSUSY1+25
7895           KCC=15+JS
7896           KCS=ISIGN(1,MINT(14+JS))
7897
7898         ELSEIF(ISUB.EQ.252) THEN
7899 C...qj + g -> ~qj_L + ~chi04
7900           IF(MINT(15).EQ.21) JS=2
7901           I=MINT(14+JS)
7902           IA=IABS(I)
7903           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7904           MINT(23-JS)=KSUSY1+35
7905           KCC=15+JS
7906           KCS=ISIGN(1,MINT(14+JS))
7907
7908         ELSEIF(ISUB.EQ.253) THEN
7909 C...qj + g -> ~qj_R + ~chi04
7910           IF(MINT(15).EQ.21) JS=2
7911           I=MINT(14+JS)
7912           IA=IABS(I)
7913           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7914           MINT(23-JS)=KSUSY1+35
7915           KCC=15+JS
7916           KCS=ISIGN(1,MINT(14+JS))
7917
7918         ELSEIF(ISUB.EQ.254) THEN
7919 C...qj + g -> ~qk_L + ~chi+-1
7920           IF(MINT(15).EQ.21) JS=2
7921           I=MINT(14+JS)
7922           IA=IABS(I)
7923           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7924           IB=-IA+INT((IA+1)/2)*4-1
7925           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7926           KCC=15+JS
7927           KCS=ISIGN(1,MINT(14+JS))
7928
7929         ELSEIF(ISUB.EQ.255) THEN
7930 C...qj + g -> ~qk_L + ~chi+-1
7931           IF(MINT(15).EQ.21) JS=2
7932           I=MINT(14+JS)
7933           IA=IABS(I)
7934           MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
7935           IB=-IA+INT((IA+1)/2)*4-1
7936           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7937           KCC=15+JS
7938           KCS=ISIGN(1,MINT(14+JS))
7939
7940         ELSEIF(ISUB.EQ.256) THEN
7941 C...qj + g -> ~qk_L + ~chi+-2
7942           IF(MINT(15).EQ.21) JS=2
7943           I=MINT(14+JS)
7944           IA=IABS(I)
7945           IB=-IA+INT((IA+1)/2)*4-1
7946           MINT(20+JS)=ISIGN(KSUSY1+IB,I)
7947           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7948           KCC=15+JS
7949           KCS=ISIGN(1,MINT(14+JS))
7950
7951         ELSEIF(ISUB.EQ.257) THEN
7952 C...qj + g -> ~qk_R + ~chi+-2
7953           IF(MINT(15).EQ.21) JS=2
7954           I=MINT(14+JS)
7955           IA=IABS(I)
7956           IB=-IA+INT((IA+1)/2)*4-1
7957           MINT(20+JS)=ISIGN(KSUSY2+IB,I)
7958           MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
7959           KCC=15+JS
7960           KCS=ISIGN(1,MINT(14+JS))
7961
7962         ELSEIF(ISUB.EQ.258) THEN
7963 C...qj + g -> ~qj_L + ~g
7964           IF(MINT(15).EQ.21) JS=2
7965           I=MINT(14+JS)
7966           IA=IABS(I)
7967           MINT(20+JS)=ISIGN(KSUSY1+IA,I)
7968           MINT(23-JS)=KSUSY1+21
7969           KCC=MINT(2)+6
7970           IF(JS.EQ.2) KCC=KCC+2
7971           KCS=ISIGN(1,I)
7972
7973         ELSEIF(ISUB.EQ.259) THEN
7974 C...qj + g -> ~qj_R + ~g
7975           IF(MINT(15).EQ.21) JS=2
7976           I=MINT(14+JS)
7977           IA=IABS(I)
7978           MINT(20+JS)=ISIGN(KSUSY2+IA,I)
7979           MINT(23-JS)=KSUSY1+21
7980           KCC=MINT(2)+6
7981           IF(JS.EQ.2) KCC=KCC+2
7982           KCS=ISIGN(1,I)
7983         ENDIF
7984
7985       ELSEIF(ISUB.LE.270) THEN
7986         IF(ISUB.EQ.261) THEN
7987 C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
7988           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7989           MINT(22)=-MINT(21)
7990 C...Correct color combination
7991           IF(MINT(43).EQ.4) KCC=4
7992
7993         ELSEIF(ISUB.EQ.262) THEN
7994 C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
7995           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
7996           MINT(22)=-MINT(21)
7997 C...Correct color combination
7998           IF(MINT(43).EQ.4) KCC=4
7999
8000         ELSEIF(ISUB.EQ.263) THEN
8001 C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
8002           IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
8003      &    (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
8004             MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8005             MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
8006           ELSE
8007             JS=2
8008             MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
8009             MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
8010           ENDIF
8011 C...Correct color combination
8012           IF(MINT(43).EQ.4) KCC=4
8013
8014         ELSEIF(ISUB.EQ.264) THEN
8015 C...g + g -> ~t_1 + ~t_1bar; th arbitrary
8016           KCS=(-1)**INT(1.5D0+PYR(0))
8017           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8018           MINT(22)=-MINT(21)
8019           KCC=MINT(2)+10
8020
8021         ELSEIF(ISUB.EQ.265) THEN
8022 C...g + g -> ~t_2 + ~t_2bar; th arbitrary
8023           KCS=(-1)**INT(1.5D0+PYR(0))
8024           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8025           MINT(22)=-MINT(21)
8026           KCC=MINT(2)+10
8027         ENDIF
8028
8029       ELSEIF(ISUB.LE.280) THEN
8030         IF(ISUB.EQ.271) THEN
8031 C...qi + qj -> ~qi_L + ~qj_L
8032           KCC=MINT(2)
8033           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8034           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8035           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8036
8037         ELSEIF(ISUB.EQ.272) THEN
8038 C...qi + qj -> ~qi_R + ~qj_R
8039           KCC=MINT(2)
8040           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8041           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8042           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8043
8044         ELSEIF(ISUB.EQ.273) THEN
8045 C...qi + qj -> ~qi_L + ~qj_R
8046           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8047           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8048           KCC=MINT(2)
8049           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8050
8051         ELSEIF(ISUB.EQ.274) THEN
8052 C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
8053           MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
8054           MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
8055           KCC=MINT(2)
8056           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8057
8058         ELSEIF(ISUB.EQ.275) THEN
8059 C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8060           MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
8061           MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
8062           KCC=MINT(2)
8063           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8064
8065         ELSEIF(ISUB.EQ.276) THEN
8066 C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
8067           MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
8068           MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
8069           KCC=MINT(2)
8070           IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
8071
8072         ELSEIF(ISUB.EQ.277) THEN
8073 C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
8074           ISGN=1
8075           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8076           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8077           MINT(22)=-MINT(21)
8078           IF(MINT(43).EQ.4) KCC=4
8079
8080         ELSEIF(ISUB.EQ.278) THEN
8081 C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
8082           ISGN=1
8083           IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
8084           MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
8085           MINT(22)=-MINT(21)
8086           IF(MINT(43).EQ.4) KCC=4
8087
8088         ELSEIF(ISUB.EQ.279) THEN
8089 C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
8090 C...pure LL + RR
8091           KCS=(-1)**INT(1.5D0+PYR(0))
8092           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8093           MINT(22)=-MINT(21)
8094           KCC=MINT(2)+10
8095
8096         ELSEIF(ISUB.EQ.280) THEN
8097 C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
8098           KCS=(-1)**INT(1.5D0+PYR(0))
8099           MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
8100           MINT(22)=-MINT(21)
8101           KCC=MINT(2)+10
8102         ENDIF
8103
8104 CMRENNA--
8105       ENDIF
8106
8107       IF(ISET(ISUB).EQ.11) THEN
8108 C...Store documentation for user-defined processes
8109         BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4))
8110         KUPPO(1)=MINT(83)+5
8111         KUPPO(2)=MINT(83)+6
8112         I=MINT(83)+6
8113         DO 450 IUP=3,NUP
8114           KUPPO(IUP)=0
8115           IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN
8116             IDOC=IDOC-1
8117             MINT(4)=MINT(4)-1
8118             GOTO 450
8119           ENDIF
8120           I=I+1
8121           KUPPO(IUP)=I
8122           K(I,1)=21
8123           K(I,2)=KUP(IUP,2)
8124           K(I,3)=0
8125           IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3))
8126           K(I,4)=0
8127           K(I,5)=0
8128           DO 440 J=1,5
8129             P(I,J)=PUP(IUP,J)
8130   440     CONTINUE
8131   450   CONTINUE
8132         CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
8133      &  -BEZUP)
8134
8135 C...Store final state partons for user-defined processes
8136         N=IPU2
8137         DO 470 IUP=3,NUP
8138           N=N+1
8139           K(N,1)=1
8140           IF(KUP(IUP,1).NE.1) K(N,1)=11
8141           K(N,2)=KUP(IUP,2)
8142           IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN
8143             K(N,3)=KUPPO(IUP)
8144           ELSE
8145             K(N,3)=MINT(84)+KUP(IUP,3)
8146           ENDIF
8147           K(N,4)=0
8148           K(N,5)=0
8149           DO 460 J=1,5
8150             P(N,J)=PUP(IUP,J)
8151   460     CONTINUE
8152   470   CONTINUE
8153         CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
8154
8155 C...Arrange colour flow for user-defined processes
8156         N=MINT(84)
8157         DO 480 IUP=1,NUP
8158           N=N+1
8159           IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480
8160           IF(K(N,1).EQ.1) K(N,1)=3
8161           IF(K(N,1).EQ.11) K(N,1)=14
8162           IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+
8163      &    MINT(84))
8164           IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+
8165      &    MINT(84))
8166           IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84)
8167           IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84)
8168   480   CONTINUE
8169
8170       ELSEIF(IDOC.EQ.7) THEN
8171 C...Resonance not decaying; store kinematics
8172         I=MINT(83)+7
8173         K(IPU3,1)=1
8174         K(IPU3,2)=KFRES
8175         K(IPU3,3)=I
8176         P(IPU3,4)=SHUSER
8177         P(IPU3,5)=SHUSER
8178         K(I,1)=21
8179         K(I,2)=KFRES
8180         P(I,4)=SHUSER
8181         P(I,5)=SHUSER
8182         N=IPU3
8183         MINT(21)=KFRES
8184         MINT(22)=0
8185
8186 C...Special cases: colour flow in coloured resonances
8187         KCRES=PYCOMP(KFRES)
8188         IF(KCHG(KCRES,2).NE.0) THEN
8189           K(IPU3,1)=3
8190           DO 490 J=1,2
8191             JC=J
8192             IF(KCS.EQ.-1) JC=3-J
8193             IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8194      &      MINT(84)+ICOL(KCC,1,JC)
8195             IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8196      &      MINT(84)+ICOL(KCC,2,JC)
8197             IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8198      &      MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8199   490     CONTINUE
8200         ELSE
8201           K(IPU1,4)=IPU2
8202           K(IPU1,5)=IPU2
8203           K(IPU2,4)=IPU1
8204           K(IPU2,5)=IPU1
8205         ENDIF
8206
8207       ELSEIF(IDOC.EQ.8) THEN
8208 C...2 -> 2 processes: store outgoing partons in their CM-frame
8209         DO 500 JT=1,2
8210           I=MINT(84)+2+JT
8211           KCA=PYCOMP(MINT(20+JT))
8212           K(I,1)=1
8213           IF(KCHG(KCA,2).NE.0) K(I,1)=3
8214           K(I,2)=MINT(20+JT)
8215           K(I,3)=MINT(83)+IDOC+JT-2
8216           KFAA=IABS(K(I,2))
8217           IF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN
8218             P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8219           ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN
8220             P(I,5)=SQRT(VINT(64))
8221           ELSE
8222             P(I,5)=PYMASS(K(I,2))
8223           ENDIF
8224           IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
8225      &    P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
8226   500   CONTINUE
8227         IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
8228           KFA1=IABS(MINT(21))
8229           KFA2=IABS(MINT(22))
8230           IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
8231      &    THEN
8232             MINT(51)=1
8233             RETURN
8234           ENDIF
8235           P(IPU3,5)=0D0
8236           P(IPU4,5)=0D0
8237         ENDIF
8238         P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
8239         P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
8240         P(IPU4,4)=SHR-P(IPU3,4)
8241         P(IPU4,3)=-P(IPU3,3)
8242         N=IPU4
8243         MINT(7)=MINT(83)+7
8244         MINT(8)=MINT(83)+8
8245
8246 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
8247         CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
8248
8249       ELSEIF(IDOC.EQ.9) THEN
8250 C...2 -> 3 processes: store outgoing partons in their CM frame
8251         DO 510 JT=1,2
8252           I=MINT(84)+2+JT
8253           KCA=PYCOMP(MINT(20+JT))
8254           K(I,1)=1
8255           IF(KCHG(KCA,2).NE.0) K(I,1)=3
8256           K(I,2)=MINT(20+JT)
8257           K(I,3)=MINT(83)+IDOC+JT-3
8258           IF(IABS(K(I,2)).LE.22) THEN
8259             P(I,5)=PYMASS(K(I,2))
8260           ELSE
8261             P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8262           ENDIF
8263           PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2))
8264           P(I,1)=PT*COS(VINT(198+5*JT))
8265           P(I,2)=PT*SIN(VINT(198+5*JT))
8266   510   CONTINUE
8267         K(IPU5,1)=1
8268         K(IPU5,2)=KFRES
8269         K(IPU5,3)=MINT(83)+IDOC
8270         P(IPU5,5)=SHR
8271         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8272         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8273         PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
8274         PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
8275         PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
8276         PMT3=SQRT(PMS3)
8277         P(IPU5,3)=PMT3*SINH(VINT(211))
8278         P(IPU5,4)=PMT3*COSH(VINT(211))
8279         PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
8280         SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
8281         IF(SQL12.LE.0D0) THEN
8282           MINT(51)=1
8283           RETURN
8284         ENDIF
8285         P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
8286      &  VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
8287         P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
8288         P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
8289         P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
8290         MINT(23)=KFRES
8291         N=IPU5
8292         MINT(7)=MINT(83)+7
8293         MINT(8)=MINT(83)+8
8294
8295       ELSEIF(IDOC.EQ.11) THEN
8296 C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
8297         PHI(1)=PARU(2)*PYR(0)
8298         PHI(2)=PHI(1)-PHIR
8299         DO 520 JT=1,2
8300           I=MINT(84)+2+JT
8301           K(I,1)=1
8302           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8303           K(I,2)=MINT(20+JT)
8304           K(I,3)=MINT(83)+IDOC+JT-2
8305           P(I,5)=PYMASS(K(I,2))
8306           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
8307             MINT(51)=1
8308             RETURN
8309           ENDIF
8310           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8311           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8312           P(I,1)=PTABS*COS(PHI(JT))
8313           P(I,2)=PTABS*SIN(PHI(JT))
8314           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8315           P(I,4)=0.5D0*SHPR*Z(JT)
8316           IZW=MINT(83)+6+JT
8317           K(IZW,1)=21
8318           K(IZW,2)=23
8319           IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
8320           K(IZW,3)=IZW-2
8321           P(IZW,1)=-P(I,1)
8322           P(IZW,2)=-P(I,2)
8323           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8324           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8325           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8326   520   CONTINUE
8327         I=MINT(83)+9
8328         K(IPU5,1)=1
8329         K(IPU5,2)=KFRES
8330         K(IPU5,3)=I
8331         P(IPU5,5)=SHR
8332         P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
8333         P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
8334         P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
8335         P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
8336         K(I,1)=21
8337         K(I,2)=KFRES
8338         DO 530 J=1,5
8339           P(I,J)=P(IPU5,J)
8340   530   CONTINUE
8341         N=IPU5
8342         MINT(23)=KFRES
8343
8344       ELSEIF(IDOC.EQ.12) THEN
8345 C...Z0 and W+/- scattering: store bosons and outgoing partons
8346         PHI(1)=PARU(2)*PYR(0)
8347         PHI(2)=PHI(1)-PHIR
8348         JTRAN=INT(1.5D0+PYR(0))
8349         DO 540 JT=1,2
8350           I=MINT(84)+2+JT
8351           K(I,1)=1
8352           IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
8353           K(I,2)=MINT(20+JT)
8354           K(I,3)=MINT(83)+IDOC+JT-2
8355           P(I,5)=PYMASS(K(I,2))
8356           IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
8357           PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
8358           PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
8359           P(I,1)=PTABS*COS(PHI(JT))
8360           P(I,2)=PTABS*SIN(PHI(JT))
8361           P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
8362           P(I,4)=0.5D0*SHPR*Z(JT)
8363           IZW=MINT(83)+6+JT
8364           K(IZW,1)=21
8365           IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
8366             K(IZW,2)=23
8367           ELSE
8368             K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
8369           ENDIF
8370           K(IZW,3)=IZW-2
8371           P(IZW,1)=-P(I,1)
8372           P(IZW,2)=-P(I,2)
8373           P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
8374           P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
8375           P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
8376           IPU=MINT(84)+4+JT
8377           K(IPU,1)=3
8378           K(IPU,2)=KFPR(ISUB,JT)
8379           IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
8380           IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
8381           K(IPU,3)=MINT(83)+8+JT
8382           IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
8383             P(IPU,5)=PYMASS(K(IPU,2))
8384           ELSE
8385             P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
8386           ENDIF
8387           MINT(22+JT)=K(IPU,2)
8388   540   CONTINUE
8389 C...Find rotation and boost for hard scattering subsystem
8390         I1=MINT(83)+7
8391         I2=MINT(83)+8
8392         BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
8393         BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
8394         BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
8395         GAMCM=(P(I1,4)+P(I2,4))/SHR
8396         BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
8397         PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
8398         PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
8399         PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
8400         THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
8401         PHICM=PYANGL(PX,PY)
8402 C...Store hard scattering subsystem. Rotate and boost it
8403         SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
8404      &  P(IPU6,5)**2
8405         PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
8406         CTHWZ=VINT(23)
8407         STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
8408         PHIWZ=VINT(24)-PHICM
8409         P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
8410         P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
8411         P(IPU5,3)=PABS*CTHWZ
8412         P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
8413         P(IPU6,1)=-P(IPU5,1)
8414         P(IPU6,2)=-P(IPU5,2)
8415         P(IPU6,3)=-P(IPU5,3)
8416         P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
8417         CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
8418         DO 560 JT=1,2
8419           I1=MINT(83)+8+JT
8420           I2=MINT(84)+4+JT
8421           K(I1,1)=21
8422           K(I1,2)=K(I2,2)
8423           DO 550 J=1,5
8424             P(I1,J)=P(I2,J)
8425   550     CONTINUE
8426   560   CONTINUE
8427         N=IPU6
8428         MINT(7)=MINT(83)+9
8429         MINT(8)=MINT(83)+10
8430       ENDIF
8431
8432       IF(ISET(ISUB).EQ.11) THEN
8433       ELSEIF(IDOC.GE.8) THEN
8434 C...Store colour connection indices
8435         DO 570 J=1,2
8436           JC=J
8437           IF(KCS.EQ.-1) JC=3-J
8438           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8439      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
8440           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8441      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
8442           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
8443      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8444           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8445      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8446   570   CONTINUE
8447
8448 C...Copy outgoing partons to documentation lines
8449         IMAX=2
8450         IF(IDOC.EQ.9) IMAX=3
8451         DO 590 I=1,IMAX
8452           I1=MINT(83)+IDOC-IMAX+I
8453           I2=MINT(84)+2+I
8454           K(I1,1)=21
8455           K(I1,2)=K(I2,2)
8456           IF(IDOC.LE.9) K(I1,3)=0
8457           IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
8458           DO 580 J=1,5
8459             P(I1,J)=P(I2,J)
8460   580     CONTINUE
8461   590   CONTINUE
8462
8463       ELSEIF(IDOC.EQ.9) THEN
8464 C...Store colour connection indices
8465         DO 600 J=1,2
8466           JC=J
8467           IF(KCS.EQ.-1) JC=3-J
8468           IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
8469      &    K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
8470      &    MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
8471           IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
8472      &    K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
8473      &    MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
8474           IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
8475      &    MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
8476           IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
8477      &    MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
8478   600   CONTINUE
8479
8480 C...Copy outgoing partons to documentation lines
8481         DO 620 I=1,3
8482           I1=MINT(83)+IDOC-3+I
8483           I2=MINT(84)+2+I
8484           K(I1,1)=21
8485           K(I1,2)=K(I2,2)
8486           K(I1,3)=0
8487           DO 610 J=1,5
8488             P(I1,J)=P(I2,J)
8489   610     CONTINUE
8490   620   CONTINUE
8491       ENDIF
8492
8493 C...Low-pT events: remove gluons used for string drawing purposes
8494       IF(ISUB.EQ.95) THEN
8495         K(IPU3,1)=K(IPU3,1)+10
8496         K(IPU4,1)=K(IPU4,1)+10
8497         DO 630 J=41,66
8498           VINTSV(J)=VINT(J)
8499           VINT(J)=0D0
8500   630   CONTINUE
8501         DO 650 I=MINT(83)+5,MINT(83)+8
8502           DO 640 J=1,5
8503             P(I,J)=0D0
8504   640     CONTINUE
8505   650   CONTINUE
8506       ENDIF
8507
8508       RETURN
8509       END
8510
8511 C*********************************************************************
8512
8513 *$ CREATE PYSSPA.FOR
8514 *COPY PYSSPA
8515 C...PYSSPA
8516 C...Generates spacelike parton showers.
8517
8518       SUBROUTINE PYSSPA(IPU1,IPU2)
8519
8520 C...Double precision and integer declarations.
8521       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8522       INTEGER PYK,PYCHGE,PYCOMP
8523 C...Commonblocks.
8524       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8525       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8526       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8527       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8528       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8529       COMMON/PYINT1/MINT(400),VINT(400)
8530       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8531       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8532       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8533      &/PYINT2/,/PYINT3/
8534 C...Local arrays and data.
8535       DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
8536      &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
8537      &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
8538      &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
8539      &THEFIS(2,2),ISFI(2)
8540       DATA IS/2*0/
8541
8542 C...Read out basic information; set global Q^2 scale.
8543       IPUS1=IPU1
8544       IPUS2=IPU2
8545       ISUB=MINT(1)
8546       Q2MX=VINT(56)
8547       IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56)
8548
8549 C...Initialize QCD evolution and check phase space.
8550       Q2MNC=PARP(62)**2
8551       Q2MNCS(1)=Q2MNC
8552       IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3)
8553      &Q2MNCS(1)=MAX(Q2MNC,VINT(283))
8554       Q2MNCS(2)=Q2MNC
8555       IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3)
8556      &Q2MNCS(2)=MAX(Q2MNC,VINT(284))
8557       MCEV=0
8558       XEC0=2D0*PARP(65)/VINT(1)
8559       ALAMS=PARU(112)
8560       PARU(112)=PARP(61)
8561       FQ2C=1D0
8562       TCMX=0D0
8563       IF(MINT(47).GE.2.AND.(MINT(47).NE.5.OR.MSTP(12).GE.1)) THEN
8564         MCEV=1
8565         IF(MSTP(64).EQ.1) FQ2C=PARP(63)
8566         IF(MSTP(64).EQ.2) FQ2C=PARP(64)
8567         TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
8568         IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
8569      &  MCEV=0
8570       ENDIF
8571
8572 C...Initialize QED evolution and check phase space.
8573       Q2MNE=PARP(68)**2
8574       MEEV=0
8575       XEE=1D-6
8576       SPME=PMAS(11,1)**2
8577       TEMX=0D0
8578       FWTE=10D0
8579       IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
8580         MEEV=1
8581         TEMX=LOG(Q2MX/SPME)
8582         IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
8583       ENDIF
8584       IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
8585
8586 C...Initial values: flavours, momenta, virtualities.
8587       NS=N
8588   100 N=NS
8589       DO 120 JT=1,2
8590         MORE(JT)=1
8591         KFBEAM(JT)=MINT(10+JT)
8592         IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
8593         KFLS(JT)=MINT(14+JT)
8594         KFLS(JT+2)=KFLS(JT)
8595         XS(JT)=VINT(40+JT)
8596         IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
8597         ZS(JT)=1D0
8598         Q2S(JT)=Q2MX
8599         TEVCSV(JT)=TCMX
8600         ALAM(JT)=PARP(61)
8601         THE2(JT)=100D0
8602         TEVESV(JT)=TEMX
8603         DO 110 KFL=-25,25
8604           XFS(JT,KFL)=XSFX(JT,KFL)
8605   110   CONTINUE
8606   120 CONTINUE
8607       DSH=VINT(44)
8608       IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
8609
8610 C...Find if interference with final state partons.
8611       MFIS=0
8612       IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
8613       IF(MFIS.NE.0) THEN
8614         DO 140 I=1,2
8615           KCFI(I)=0
8616           KCA=PYCOMP(IABS(KFLS(I)))
8617           IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
8618           NFIS(I)=0
8619           IF(KCFI(I).NE.0) THEN
8620             IF(I.EQ.1) IPFS=IPUS1
8621             IF(I.EQ.2) IPFS=IPUS2
8622             DO 130 J=1,2
8623               ICSI=MOD(K(IPFS,3+J),MSTU(5))
8624               IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
8625      &        (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
8626                 NFIS(I)=NFIS(I)+1
8627                 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
8628      &          P(ICSI,2)**2))
8629                 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
8630               ENDIF
8631   130       CONTINUE
8632           ENDIF
8633   140   CONTINUE
8634         IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
8635       ENDIF
8636
8637 C...Pick up leg with highest virtuality.
8638   150 N=N+1
8639       JT=1
8640       IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
8641       IF(MORE(JT).EQ.0) JT=3-JT
8642       KFLB=KFLS(JT)
8643       XB=XS(JT)
8644       DO 160 KFL=-25,25
8645         XFB(KFL)=XFS(JT,KFL)
8646   160 CONTINUE
8647       DSHR=2D0*SQRT(DSH)
8648       DSHZ=DSH/ZS(JT)
8649
8650 C...Check if allowed to branch.
8651       MCEV=0
8652       IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
8653         MCEV=1
8654         XEC=MAX(XEC0,XB*(1D0/(1D0-PARP(66))-1D0))
8655         IF(XB.GE.1D0-2D0*XEC) MCEV=0
8656       ENDIF
8657       MEEV=0
8658       IF(MINT(44+JT).EQ.3) THEN
8659         MEEV=1
8660         IF(XB.GE.1D0-2D0*XEE) MEEV=0
8661         IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
8662      &  MEEV=0
8663 C***Currently kill QED shower for resolved photoproduction.
8664         IF(MINT(18+JT).EQ.1) MEEV=0
8665 C***Currently kill shower for W inside electron.
8666         IF(IABS(KFLB).EQ.24) THEN
8667           MCEV=0
8668           MEEV=0
8669         ENDIF
8670       ENDIF
8671       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8672         Q2B=0D0
8673         GOTO 250
8674       ENDIF
8675
8676 C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
8677       Q2B=Q2S(JT)
8678       TEVCB=TEVCSV(JT)
8679       TEVEB=TEVESV(JT)
8680       IF(MSTP(62).LE.1) THEN
8681         IF(ZS(JT).GT.0.99999D0) THEN
8682           Q2B=Q2S(JT)
8683         ELSE
8684           Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
8685      &    (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
8686      &    8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
8687         ENDIF
8688         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8689         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8690       ENDIF
8691       IF(MCEV.EQ.1) THEN
8692         ALSDUM=PYALPS(FQ2C*Q2B)
8693         TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
8694         ALAM(JT)=PARU(117)
8695         B0=(33D0-2D0*MSTU(118))/6D0
8696       ENDIF
8697       TEVCBS=TEVCB
8698       TEVEBS=TEVEB
8699
8700 C...Select side for interference with final state partons.
8701       IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
8702         IFI=N-NS
8703         ISFI(IFI)=0
8704         IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
8705           ISFI(IFI)=1
8706         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
8707           IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
8708         ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
8709           ISFI(IFI)=1
8710           IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
8711         ENDIF
8712       ENDIF
8713
8714 C...Calculate Altarelli-Parisi weights.
8715       DO 170 KFL=-25,25
8716         WTAPC(KFL)=0D0
8717         WTAPE(KFL)=0D0
8718         WTSF(KFL)=0D0
8719   170 CONTINUE
8720 C...q -> q, g -> q.
8721       IF(IABS(KFLB).LE.10) THEN
8722         WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
8723         WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
8724 C...f -> f, gamma -> f.
8725       ELSEIF(IABS(KFLB).LE.20) THEN
8726         WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
8727         WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
8728         WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
8729         IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
8730 C...f -> g, g -> g.
8731       ELSEIF(KFLB.EQ.21) THEN
8732         WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
8733         DO 180 KFL=1,MSTP(58)
8734           WTAPC(KFL)=WTAPQ
8735           WTAPC(-KFL)=WTAPQ
8736   180   CONTINUE
8737         WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
8738 C...f -> gamma, W+, W-.
8739       ELSEIF(KFLB.EQ.22) THEN
8740         WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
8741         WTAPE(11)=WTAPF
8742         WTAPE(-11)=WTAPF
8743       ELSEIF(KFLB.EQ.24) THEN
8744         WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8745      &  (XEE*(XB+XEE)))/XB
8746       ELSEIF(KFLB.EQ.-24) THEN
8747         WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
8748      &  (XEE*(XB+XEE)))/XB
8749       ENDIF
8750
8751 C...Calculate parton distribution weights and sum.
8752       NTRY=0
8753   190 NTRY=NTRY+1
8754       IF(NTRY.GT.500) THEN
8755         MINT(51)=1
8756         RETURN
8757       ENDIF
8758       WTSUMC=0D0
8759       WTSUME=0D0
8760       XFBO=MAX(1D-10,XFB(KFLB))
8761       DO 200 KFL=-25,25
8762         WTSF(KFL)=XFB(KFL)/XFBO
8763         WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
8764         WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
8765   200 CONTINUE
8766       WTSUMC=MAX(0.0001D0,WTSUMC)
8767       WTSUME=MAX(0.0001D0/FWTE,WTSUME)
8768
8769 C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
8770       NTRY2=0
8771   210 NTRY2=NTRY2+1
8772       IF(NTRY2.GT.500) THEN
8773         MINT(51)=1
8774         RETURN
8775       ENDIF
8776       IF(MCEV.EQ.1) THEN
8777         IF(MSTP(64).LE.0) THEN
8778           TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
8779         ELSEIF(MSTP(64).EQ.1) THEN
8780           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
8781         ELSE
8782           TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
8783         ENDIF
8784       ENDIF
8785       IF(MEEV.EQ.1) THEN
8786         TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
8787      &  (PARU(101)*FWTE*WTSUME*TEMX)))
8788       ENDIF
8789
8790 C...Translate t into Q2 scale; choose between QCD and QED evolution.
8791   220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
8792       IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
8793       MCE=0
8794       IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
8795       ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
8796         IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
8797       ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
8798         IF(Q2EB.GT.Q2MNE) MCE=2
8799       ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
8800         MCE=1
8801         IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
8802         IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
8803       ELSE
8804         MCE=2
8805         IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
8806         IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
8807       ENDIF
8808
8809 C...Evolution possibly ended. Update t values.
8810       IF(MCE.EQ.0) THEN
8811         Q2B=0D0
8812         GOTO 250
8813       ELSEIF(MCE.EQ.1) THEN
8814         Q2B=Q2CB
8815         Q2REF=FQ2C*Q2B
8816         IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
8817       ELSE
8818         Q2B=Q2EB
8819         Q2REF=Q2B
8820         IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
8821       ENDIF
8822
8823 C...Select flavour for branching parton.
8824       IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
8825       IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
8826       KFLA=-25
8827   230 KFLA=KFLA+1
8828       IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
8829       IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
8830       IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 230
8831       IF(KFLA.EQ.25) THEN
8832         Q2B=0D0
8833         GOTO 250
8834       ENDIF
8835
8836 C...Choose z value and corrective weight.
8837       WTZ=0D0
8838 C...q -> q + g.
8839       IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
8840         Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
8841      &  (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
8842         WTZ=0.5D0*(1D0+Z**2)
8843 C...q -> g + q.
8844       ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
8845         Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
8846         WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
8847 C...f -> f + gamma.
8848       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
8849         IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
8850           Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
8851      &    (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
8852         ELSE
8853           Z=XB+XB*(XEE/(1D0-XEE))*
8854      &    ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8855         ENDIF
8856         WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
8857 C...f -> gamma + f.
8858       ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
8859         Z=XB+XB*(XEE/(1D0-XEE))*
8860      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8861         WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
8862 C...f -> W+- + f'.
8863       ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
8864         Z=XB+XB*(XEE/(1D0-XEE))*
8865      &  ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
8866         WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
8867      &  (Q2B/(Q2B+PMAS(24,1)**2))
8868 C...g -> q + qbar.
8869       ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
8870         Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
8871         WTZ=1D0-2D0*Z*(1D0-Z)
8872 C...g -> g + g.
8873       ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
8874         Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
8875         WTZ=(1D0-Z*(1D0-Z))**2
8876 C...gamma -> f + fbar.
8877       ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
8878         Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
8879         WTZ=1D0-2D0*Z*(1D0-Z)
8880       ENDIF
8881       IF(MCE.EQ.2) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
8882
8883 C...Option with resummation of soft gluon emission as effective z shift.
8884       IF(MCE.EQ.1) THEN
8885         IF(MSTP(65).GE.1) THEN
8886           RSOFT=6D0
8887           IF(KFLB.NE.21) RSOFT=8D0/3D0
8888           Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
8889           IF(Z.LE.XB) GOTO 210
8890         ENDIF
8891
8892 C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
8893         IF(MSTP(64).GE.2) THEN
8894           IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 210
8895           ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
8896           IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210
8897           IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
8898         ENDIF
8899
8900 C...Impose angular constraint in first branching from interference
8901 C...with final state partons.
8902         IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
8903           THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
8904           IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
8905             IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 210
8906           ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
8907             IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210
8908           ENDIF
8909         ENDIF
8910
8911 C...Option with angular ordering requirement.
8912         IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
8913           THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2)
8914           IF(THE2T.GT.THE2(JT)) GOTO 210
8915         ENDIF
8916       ENDIF
8917
8918 C...Weighting with new parton distributions.
8919       MINT(105)=MINT(102+JT)
8920       MINT(109)=MINT(106+JT)
8921       IF(MSTP(57).LE.1) THEN
8922         CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
8923       ELSE
8924         CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
8925       ENDIF
8926       XFBN=XFN(KFLB)
8927       IF(XFBN.LT.1D-20) THEN
8928         IF(KFLA.EQ.KFLB) THEN
8929           TEVCB=TEVCBS
8930           TEVEB=TEVEBS
8931           WTAPC(KFLB)=0D0
8932           WTAPE(KFLB)=0D0
8933           GOTO 190
8934         ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
8935           TEVCB=0.5D0*(TEVCBS+TEVCB)
8936           GOTO 220
8937         ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
8938           TEVEB=0.5D0*(TEVEBS+TEVEB)
8939           GOTO 220
8940         ELSE
8941           XFBN=1D-10
8942           XFN(KFLB)=XFBN
8943         ENDIF
8944       ENDIF
8945       DO 240 KFL=-25,25
8946         XFB(KFL)=XFN(KFL)
8947   240 CONTINUE
8948       XA=XB/Z
8949       IF(MSTP(57).LE.1) THEN
8950         CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
8951       ELSE
8952         CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
8953       ENDIF
8954       XFAN=XFA(KFLA)
8955       IF(XFAN.LT.1D-20) GOTO 190
8956       WTSFA=WTSF(KFLA)
8957       IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190
8958
8959 C...Define two hard scatterers in their CM-frame.
8960   250 IF(N.EQ.NS+2) THEN
8961         DQ2(JT)=Q2B
8962         DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
8963         DO 270 JR=1,2
8964           I=NS+JR
8965           IF(JR.EQ.1) IPO=IPUS1
8966           IF(JR.EQ.2) IPO=IPUS2
8967           DO 260 J=1,5
8968             K(I,J)=0
8969             P(I,J)=0D0
8970             V(I,J)=0D0
8971   260     CONTINUE
8972           K(I,1)=14
8973           K(I,2)=KFLS(JR+2)
8974           K(I,4)=IPO
8975           K(I,5)=IPO
8976           P(I,3)=DPLCM*(-1)**(JR+1)
8977           P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
8978           P(I,5)=-SQRT(DQ2(JR))
8979           K(IPO,1)=14
8980           K(IPO,3)=I
8981           K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
8982           K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
8983   270   CONTINUE
8984
8985 C...Find maximum allowed mass of timelike parton.
8986       ELSEIF(N.GT.NS+2) THEN
8987         JR=3-JT
8988         DQ2(3)=Q2B
8989         DPC(1)=P(IS(1),4)
8990         DPC(2)=P(IS(2),4)
8991         DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
8992         DPD(1)=DSH+DQ2(JR)+DQ2(JT)
8993         DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
8994         DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
8995         DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
8996         IKIN=0
8997         IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
8998      &  1D-10*DPD(1)) IKIN=1
8999         IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
9000      &  (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
9001         IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
9002      &  (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
9003
9004 C...Generate timelike parton shower (if required).
9005         IT=N
9006         DO 280 J=1,5
9007           K(IT,J)=0
9008           P(IT,J)=0D0
9009           V(IT,J)=0D0
9010   280   CONTINUE
9011         K(IT,1)=3
9012 C...f -> f + g (gamma).
9013         IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
9014           K(IT,2)=21
9015           IF(IABS(KFLB).GE.11) K(IT,2)=22
9016 C...f -> g (gamma, W+-) + f.
9017         ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
9018           K(IT,2)=KFLB
9019           IF(KFLS(JT+2).EQ.24) THEN
9020             K(IT,2)=-12
9021           ELSEIF(KFLS(JT+2).EQ.-24) THEN
9022             K(IT,2)=12
9023           ENDIF
9024 C...g (gamma) -> f + fbar, g + g.
9025         ELSE
9026           K(IT,2)=-KFLS(JT+2)
9027           IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
9028         ENDIF
9029         P(IT,5)=PYMASS(K(IT,2))
9030         IF(DMSMA.LE.P(IT,5)**2) GOTO 100
9031         IF(MSTP(63).GE.1.AND.MCE.EQ.1) THEN
9032           MSTJ48=MSTJ(48)
9033           PARJ85=PARJ(85)
9034           P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
9035           P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
9036           IF(MSTP(63).EQ.1) THEN
9037             Q2TIM=DMSMA
9038           ELSEIF(MSTP(63).EQ.2) THEN
9039             Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
9040           ELSE
9041             Q2TIM=DMSMA
9042             MSTJ(48)=1
9043             IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9044             IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
9045      &      DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
9046             PARJ(85)=SQRT(MAX(0D0,DPT2))*
9047      &      (1D0/P(IT,4)+1D0/P(IS(JT),4))
9048           ENDIF
9049           CALL PYSHOW(IT,0,SQRT(Q2TIM))
9050           MSTJ(48)=MSTJ48
9051           PARJ(85)=PARJ85
9052           IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
9053         ENDIF
9054
9055 C...Reconstruct kinematics of branching: timelike parton shower.
9056         DMS=P(IT,5)**2
9057         IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
9058         IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
9059      &  0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
9060      &  (4D0*DSH*DPC(3)**2)
9061         IF(DPT2.LT.0D0) GOTO 100
9062         DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
9063      &  DSHR)/DPC(3)-DPC(3)
9064         P(IT,1)=SQRT(DPT2)
9065         P(IT,3)=DPB(1)*(-1)**(JT+1)
9066         P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
9067         IF(N.GE.IT+1) THEN
9068           DPB(1)=SQRT(DPB(1)**2+DPT2)
9069           DPB(2)=SQRT(DPB(1)**2+DMS)
9070           DPB(3)=P(IT+1,3)
9071           DPB(4)=SQRT(DPB(3)**2+DMS)
9072           DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
9073      &    DPB(1))
9074           CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
9075           THE=PYANGL(P(IT,3),P(IT,1))
9076           CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
9077         ENDIF
9078
9079 C...Reconstruct kinematics of branching: spacelike parton.
9080         DO 290 J=1,5
9081           K(N+1,J)=0
9082           P(N+1,J)=0D0
9083           V(N+1,J)=0D0
9084   290   CONTINUE
9085         K(N+1,1)=14
9086         K(N+1,2)=KFLB
9087         P(N+1,1)=P(IT,1)
9088         P(N+1,3)=P(IT,3)+P(IS(JT),3)
9089         P(N+1,4)=P(IT,4)+P(IS(JT),4)
9090         P(N+1,5)=-SQRT(DQ2(3))
9091
9092 C...Define colour flow of branching.
9093         K(IS(JT),3)=N+1
9094         K(IT,3)=N+1
9095         IM1=N+1
9096         IM2=N+1
9097 C...f -> f + gamma (Z, W).
9098         IF(IABS(K(IT,2)).GE.22) THEN
9099           K(IT,1)=1
9100           ID1=IS(JT)
9101           ID2=IS(JT)
9102 C...f -> gamma (Z, W) + f.
9103         ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
9104           ID1=IT
9105           ID2=IT
9106 C...gamma -> q + qbar, g + g.
9107         ELSEIF(K(N+1,2).EQ.22) THEN
9108           ID1=IS(JT)
9109           ID2=IT
9110           IM1=ID2
9111           IM2=ID1
9112 C...q -> q + g.
9113         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
9114           ID1=IT
9115           ID2=IS(JT)
9116 C...q -> g + q.
9117         ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
9118           ID1=IS(JT)
9119           ID2=IT
9120 C...qbar -> qbar + g.
9121         ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
9122           ID1=IS(JT)
9123           ID2=IT
9124 C...qbar -> g + qbar.
9125         ELSEIF(K(N+1,2).LT.0) THEN
9126           ID1=IT
9127           ID2=IS(JT)
9128 C...g -> g + g; g -> q + qbar.
9129         ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
9130           ID1=IS(JT)
9131           ID2=IT
9132         ELSE
9133           ID1=IT
9134           ID2=IS(JT)
9135         ENDIF
9136         IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
9137         IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
9138         K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
9139         K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
9140         IF(ID1.NE.ID2) THEN
9141           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
9142           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
9143         ENDIF
9144         N=N+1
9145
9146 C...Boost to new CM-frame.
9147         DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
9148         DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
9149         IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
9150         CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
9151         IR=N+(JT-1)*(IS(1)-N)
9152         CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),PARU(2)*PYR(0),
9153      &  0D0,0D0,0D0)
9154       ENDIF
9155
9156 C...Update kinematics variables.
9157       IS(JT)=N
9158       DQ2(JT)=Q2B
9159       IF(MSTP(62).GE.3) THE2(JT)=THE2T
9160       DSH=DSHZ
9161
9162 C...Save quantities; loop back.
9163       Q2S(JT)=Q2B
9164       IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
9165      &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
9166         KFLS(JT+2)=KFLS(JT)
9167         KFLS(JT)=KFLA
9168         XS(JT)=XA
9169         ZS(JT)=Z
9170         DO 300 KFL=-25,25
9171           XFS(JT,KFL)=XFA(KFL)
9172   300   CONTINUE
9173         TEVCSV(JT)=TEVCB
9174         TEVESV(JT)=TEVEB
9175       ELSE
9176         MORE(JT)=0
9177         IF(JT.EQ.1) IPU1=N
9178         IF(JT.EQ.2) IPU2=N
9179       ENDIF
9180       IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
9181         CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
9182         IF(MSTU(21).GE.1) N=NS
9183         IF(MSTU(21).GE.1) RETURN
9184       ENDIF
9185       IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
9186
9187 C...Boost hard scattering partons to frame of shower initiators.
9188       DO 310 J=1,3
9189         ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
9190   310 CONTINUE
9191       K(N+2,1)=1
9192       DO 320 J=1,5
9193         P(N+2,J)=P(NS+1,J)
9194   320 CONTINUE
9195       ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2
9196       IF(ROBOT.GE.0.999999D0) THEN
9197         ROBOT=1.00001D0*SQRT(ROBOT)
9198         ROBO(3)=ROBO(3)/ROBOT
9199         ROBO(4)=ROBO(4)/ROBOT
9200         ROBO(5)=ROBO(5)/ROBOT
9201       ENDIF
9202       CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
9203       ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
9204       ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
9205       CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),
9206      &ROBO(5))
9207
9208 C...Store user information. Reset Lambda value.
9209       K(IPU1,3)=MINT(83)+3
9210       K(IPU2,3)=MINT(83)+4
9211       DO 330 JT=1,2
9212         MINT(12+JT)=KFLS(JT)
9213         VINT(140+JT)=XS(JT)
9214         IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
9215   330 CONTINUE
9216       PARU(112)=ALAMS
9217
9218       RETURN
9219       END
9220
9221 C*********************************************************************
9222
9223 *$ CREATE PYRESD.FOR
9224 *COPY PYRESD
9225 C...PYRESD
9226 C...Allows resonances to decay (including parton showers for hadronic
9227 C...channels).
9228
9229       SUBROUTINE PYRESD(IRES)
9230
9231 C...Double precision and integer declarations.
9232       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9233       INTEGER PYK,PYCHGE,PYCOMP
9234 C...Parameter statement to help give large particle numbers.
9235       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
9236 C...Commonblocks.
9237       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9238       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9239       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9240       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
9241       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9242       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9243       COMMON/PYINT1/MINT(400),VINT(400)
9244       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9245       COMMON/PYINT4/MWID(500),WIDS(500,5)
9246       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
9247      &/PYINT1/,/PYINT2/,/PYINT4/
9248 C...Local arrays and complex and character variables.
9249       DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
9250      &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
9251      &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
9252      &PHI(3),WDTP(0:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5)
9253       COMPLEX FGK,HA(6,6),HC(6,6)
9254       REAL TIR,UIR
9255       CHARACTER CODE*9,MASS*9
9256
9257 C...The F, Xi and Xj functions of Gunion and Kunszt
9258 C...(Phys. Rev. D33, 665, plus errata from the authors).
9259       FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
9260      &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
9261       DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
9262      &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
9263       DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
9264      &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
9265      &2D0*(D34/D56+D56/D34))
9266
9267 C...Some general constants.
9268       XW=PARU(102)
9269       XWV=XW
9270       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
9271       XW1=1D0-XW
9272       SQMZ=PMAS(23,1)**2
9273       GMMZ=PMAS(23,1)*PMAS(23,2)
9274       SQMW=PMAS(24,1)**2
9275       GMMW=PMAS(24,1)*PMAS(24,2)
9276       SH=VINT(44)
9277
9278 C...Reset original resonance configuration.
9279       DO 100 JT=1,8
9280         IREF(1,JT)=0
9281   100 CONTINUE
9282
9283 C...Define initial one, two or three objects for subprocess.
9284       IF(IRES.EQ.0) THEN
9285         ISUB=MINT(1)
9286         IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
9287           IREF(1,1)=MINT(84)+2+ISET(ISUB)
9288           IREF(1,4)=MINT(83)+6+ISET(ISUB)
9289         ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
9290           IREF(1,1)=MINT(84)+1+ISET(ISUB)
9291           IREF(1,2)=MINT(84)+2+ISET(ISUB)
9292           IREF(1,4)=MINT(83)+5+ISET(ISUB)
9293           IREF(1,5)=MINT(83)+6+ISET(ISUB)
9294         ELSEIF(ISET(ISUB).EQ.5) THEN
9295           IREF(1,1)=MINT(84)+3
9296           IREF(1,2)=MINT(84)+4
9297           IREF(1,3)=MINT(84)+5
9298           IREF(1,4)=MINT(83)+7
9299           IREF(1,5)=MINT(83)+8
9300           IREF(1,6)=MINT(83)+9
9301         ENDIF
9302
9303 C...Define original resonance for odd cases.
9304       ELSE
9305         ISUB=0
9306         IREF(1,1)=IRES
9307       ENDIF
9308
9309 C...Check if initial resonance has been moved (in resonance + jet).
9310       DO 120 JT=1,3
9311         IF(IREF(1,JT).GT.0) THEN
9312           IF(K(IREF(1,JT),1).GT.10) THEN
9313             KFA=IABS(K(IREF(1,JT),2))
9314             IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
9315               DO 110 I=IREF(1,JT)+1,N
9316                 IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2))
9317      &          IREF(1,JT)=I
9318   110         CONTINUE
9319             ELSE
9320               KDA=MOD(K(IREF(1,JT),4),MSTU(4))
9321               IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
9322             ENDIF
9323           ENDIF
9324         ENDIF
9325   120 CONTINUE
9326
9327 C...Loop over decay history.
9328       NP=1
9329       IP=0
9330   130 IP=IP+1
9331       NINH=0
9332       JTMAX=2
9333       IF(IREF(IP,2).EQ.0) JTMAX=1
9334       IF(IREF(IP,3).NE.0) JTMAX=3
9335       IT4=0
9336       NSAV=N
9337
9338 C...Start treatment of one, two or three resonances in parallel.
9339   140 N=NSAV
9340       DO 220 JT=1,JTMAX
9341         ID=IREF(IP,JT)
9342         KDCY(JT)=0
9343         KFL1(JT)=0
9344         KFL2(JT)=0
9345         KFL3(JT)=0
9346         KEQL(JT)=0
9347         NSD(JT)=ID
9348
9349 C...Check whether particle can/is allowed to decay.
9350         IF(ID.EQ.0) GOTO 210
9351         KFA=IABS(K(ID,2))
9352         KCA=PYCOMP(KFA)
9353         IF(MWID(KCA).EQ.0) GOTO 210
9354         IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210
9355         IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
9356      &  KFA.EQ.18) IT4=IT4+1
9357         K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
9358         K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
9359
9360 C...Info for selection of decay channel: sign, pairings.
9361         IF(KCHG(KCA,3).EQ.0) THEN
9362           IPM=2
9363         ELSE
9364           IPM=(5-ISIGN(1,K(ID,2)))/2
9365         ENDIF
9366         KFB=0
9367         IF(JTMAX.EQ.2) THEN
9368           KFB=IABS(K(IREF(IP,3-JT),2))
9369         ELSEIF(JTMAX.EQ.3) THEN
9370           JT2=JT+1-3*(JT/3)
9371           KFB=IABS(K(IREF(IP,JT2),2))
9372           IF(KFB.NE.KFA) THEN
9373             JT2=JT+2-3*((JT+1)/3)
9374             KFB=IABS(K(IREF(IP,JT2),2))
9375           ENDIF
9376         ENDIF
9377
9378 C...Select decay channel.
9379         IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
9380      &  ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
9381         CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
9382         WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
9383         IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
9384         IF(WDTE0S.LE.0D0) GOTO 210
9385         RKFL=WDTE0S*PYR(0)
9386         IDL=0
9387   150   IDL=IDL+1
9388         IDC=IDL+MDCY(KCA,2)-1
9389         RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
9390         IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
9391         IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 150
9392
9393 C...Read out flavours and colour charges of decay channel chosen.
9394         KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
9395         IF(KCQM(JT).EQ.-2) KCQM(JT)=2
9396         KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
9397         KFC1A=PYCOMP(IABS(KFL1(JT)))
9398         IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
9399         KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
9400         IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
9401         KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
9402         KFC2A=PYCOMP(IABS(KFL2(JT)))
9403         IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
9404         KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
9405         IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
9406         KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
9407         IF(KFL3(JT).NE.0) THEN
9408           KFC3A=PYCOMP(IABS(KFL3(JT)))
9409           IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
9410           KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
9411           IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
9412         ENDIF
9413
9414 C...Set/save further info on channel.
9415         KDCY(JT)=1
9416         IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
9417         NSD(JT)=N
9418         HGZ(JT,1)=VINT(111)
9419         HGZ(JT,2)=VINT(112)
9420         HGZ(JT,3)=VINT(114)
9421
9422 C...Select masses; to begin with assume resonances narrow.
9423         DO 170 I=1,3
9424           P(N+I,5)=0D0
9425           PMMN(I)=0D0
9426           IF(I.EQ.1) THEN
9427             KFLW=IABS(KFL1(JT))
9428             KCW=KFC1A
9429           ELSEIF(I.EQ.2) THEN
9430             KFLW=IABS(KFL2(JT))
9431             KCW=KFC2A
9432           ELSEIF(I.EQ.3) THEN
9433             IF(KFL3(JT).EQ.0) GOTO 170
9434             KFLW=IABS(KFL3(JT))
9435             KCW=KFC3A
9436           ENDIF
9437           P(N+I,5)=PMAS(KCW,1)
9438 CMRENNA++
9439 C...This prevents SUSY/t particles from becoming too light.
9440           IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9441             PMMN(I)=PMAS(KCW,1)
9442             DO 160 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9443               IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9444                 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9445      &          PMAS(PYCOMP(KFDP(IDC,2)),1)
9446                 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9447      &          PMAS(PYCOMP(KFDP(IDC,3)),1)
9448                 PMMN(I)=MIN(PMMN(I),PMSUM)
9449               ENDIF
9450   160       CONTINUE
9451 CMRENNA--
9452           ELSEIF(KFLW.EQ.6) THEN
9453             PMMN(I)=PMAS(24,1)+PMAS(5,1)
9454           ENDIF
9455   170   CONTINUE
9456
9457 C...Check which two out of three are widest.
9458         IWID1=1
9459         IWID2=2
9460         PWID1=PMAS(KFC1A,2)
9461         PWID2=PMAS(KFC2A,2)
9462         KFLW1=IABS(KFL1(JT))
9463         KFLW2=IABS(KFL2(JT))
9464         IF(KFL3(JT).NE.0) THEN
9465           PWID3=PMAS(KFC3A,2)
9466           IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
9467             IWID1=3
9468             PWID1=PWID3
9469             KFLW1=IABS(KFL3(JT))
9470           ELSEIF(PWID3.GT.PWID2) THEN
9471             IWID2=3
9472             PWID2=PWID3
9473             KFLW2=IABS(KFL3(JT))
9474           ENDIF
9475         ENDIF
9476
9477 C...If all narrow then only check that masses consistent.
9478         IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
9479      &  PWID2.LT.PARP(41))) THEN
9480 CMRENNA++
9481 C....Handle near degeneracy cases.
9482           IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
9483             IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
9484               P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
9485               IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
9486             ENDIF
9487           ENDIF
9488 CMRENNA--
9489           IF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
9490             CALL PYERRM(13,'(PYRESD:) daughter masses too large')
9491             MINT(51)=1
9492             RETURN
9493           ENDIF
9494
9495 C...For three wide resonances select narrower of three
9496 C...according to BW decoupled from rest.
9497         ELSE
9498           PMTOT=P(ID,5)
9499           IF(KFL3(JT).NE.0) THEN
9500             IWID3=6-IWID1-IWID2
9501             KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
9502      &      KFLW1-KFLW2
9503             LOOP=0
9504   180       LOOP=LOOP+1
9505             P(N+IWID3,5)=PYMASS(KFLW3)
9506             IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180
9507             PMTOT=PMTOT-P(N+IWID3,5)
9508           ENDIF
9509 C...Select other two correlated within remaining phase space.
9510           IF(IP.EQ.1) THEN
9511             CKIN45=CKIN(45)
9512             CKIN47=CKIN(47)
9513             CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
9514             CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
9515             CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9516      &      P(N+IWID2,5))
9517             CKIN(45)=CKIN45
9518             CKIN(47)=CKIN47
9519           ELSE
9520             CKIN(49)=PMMN(IWID1)
9521             CKIN(50)=PMMN(IWID2)
9522             CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
9523      &      P(N+IWID2,5))
9524             CKIN(49)=0D0
9525             CKIN(50)=0D0
9526           ENDIF
9527           IF(MINT(51).EQ.1) RETURN
9528         ENDIF
9529
9530 C...Begin fill decay products, with colour flow for coloured objects.
9531         MSTU10=MSTU(10)
9532         MSTU(10)=1
9533         MSTU(19)=1
9534
9535 CMRENNA++
9536 C...1) Three-body decays of SUSY particles (plus special case top).
9537         IF(KFL3(JT).NE.0) THEN
9538           DO 200 I=N+1,N+3
9539             DO 190 J=1,5
9540               K(I,J)=0
9541               V(I,J)=0D0
9542   190       CONTINUE
9543   200     CONTINUE
9544           XM(1)=P(N+1,5)
9545           XM(2)=P(N+2,5)
9546           XM(3)=P(N+3,5)
9547           XM(5)=P(ID,5)
9548           CALL PYTBDY(XM)
9549           K(N+1,1)=1
9550           K(N+1,2)=KFL1(JT)
9551           K(N+2,1)=1
9552           K(N+2,2)=KFL2(JT)
9553           K(N+3,1)=1
9554           K(N+3,2)=KFL3(JT)
9555
9556 C...Set colour flow for t -> W + b + Z.
9557           IF(KFA.EQ.6) THEN
9558             K(N+2,1)=3
9559             ISID=4
9560             IF(KCQM(JT).EQ.-1) ISID=5
9561             IDAU=N+2
9562             K(ID,ISID)=K(ID,ISID)+IDAU
9563             K(IDAU,ISID)=MSTU(5)*ID
9564
9565 C...Set colour flow in three-body decays - programmed as special cases.
9566           ELSEIF(KFC2A.LE.6) THEN
9567             K(N+2,1)=3
9568             K(N+3,1)=3
9569             ISID=4
9570             IF(KFL2(JT).LT.0) ISID=5
9571             K(N+2,ISID)=MSTU(5)*(N+3)
9572             K(N+3,9-ISID)=MSTU(5)*(N+2)
9573           ENDIF
9574           IF(KFL1(JT).EQ.KSUSY1+21) THEN
9575             K(N+1,1)=3
9576             K(N+2,1)=3
9577             K(N+3,1)=3
9578             ISID=4
9579             IF(KFL2(JT).LT.0) ISID=5
9580             K(N+1,ISID)=MSTU(5)*(N+2)
9581             K(N+1,9-ISID)=MSTU(5)*(N+3)
9582             K(N+2,ISID)=MSTU(5)*(N+1)
9583             K(N+3,9-ISID)=MSTU(5)*(N+1)
9584           ENDIF
9585           IF(KFA.EQ.KSUSY1+21) THEN
9586             K(N+2,1)=3
9587             K(N+3,1)=3
9588             ISID=4
9589             IF(KFL2(JT).LT.0) ISID=5
9590             K(ID,ISID)=K(ID,ISID)+(N+2)
9591             K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
9592             K(N+2,ISID)=MSTU(5)*ID
9593             K(N+3,9-ISID)=MSTU(5)*ID
9594           ENDIF
9595           N=N+3
9596 CMRENNA--
9597
9598 C...2) Everything else two-body decay.
9599         ELSE
9600           CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
9601 C...First set colour flow as if mother colour singlet.
9602           IF(KCQ1(JT).NE.0) THEN
9603             K(N-1,1)=3
9604             IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
9605             IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
9606           ENDIF
9607           IF(KCQ2(JT).NE.0) THEN
9608             K(N,1)=3
9609             IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
9610             IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
9611           ENDIF
9612 C...Then redirect colour flow if mother (anti)triplet.
9613           IF(KCQM(JT).EQ.0) THEN
9614           ELSEIF(KCQM(JT).NE.2) THEN
9615             ISID=4
9616             IF(KCQM(JT).EQ.-1) ISID=5
9617             IDAU=N-1
9618             IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
9619             K(ID,ISID)=K(ID,ISID)+IDAU
9620             K(IDAU,ISID)=MSTU(5)*ID
9621 C...Then redirect colour flow if mother octet.
9622           ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
9623             IDAU=N-1
9624             IF(KCQ1(JT).EQ.0) IDAU=N
9625             K(ID,4)=K(ID,4)+IDAU
9626             K(ID,5)=K(ID,5)+IDAU
9627             K(IDAU,4)=MSTU(5)*ID
9628             K(IDAU,5)=MSTU(5)*ID
9629           ELSE
9630             ISID=4
9631             IF(KCQ1(JT).EQ.-1) ISID=5
9632             IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
9633             K(ID,ISID)=K(ID,ISID)+(N-1)
9634             K(ID,9-ISID)=K(ID,9-ISID)+N
9635             K(N-1,ISID)=MSTU(5)*ID
9636             K(N,9-ISID)=MSTU(5)*ID
9637           ENDIF
9638         ENDIF
9639
9640 C...End loop over resonances for daughter flavour and mass selection.
9641         MSTU(10)=MSTU10
9642   210   IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
9643      &  NINH=NINH+1
9644         IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.KFL1(JT).EQ.0) THEN
9645           WRITE(CODE,'(I9)') K(ID,2)
9646           WRITE(MASS,'(F9.3)') P(ID,5)
9647           CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
9648      &    CODE//' with mass'//MASS)
9649           MINT(51)=1
9650           RETURN
9651         ENDIF
9652   220 CONTINUE
9653
9654 C...Check for allowed combinations. Skip if no decays.
9655       IF(JTMAX.EQ.1) THEN
9656         IF(KDCY(1).EQ.0) GOTO 560
9657       ELSEIF(JTMAX.EQ.2) THEN
9658         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560
9659         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9660         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9661       ELSEIF(JTMAX.EQ.3) THEN
9662         IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560
9663         IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140
9664         IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9665         IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140
9666         IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140
9667         IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9668         IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140
9669       ENDIF
9670
9671 C...Special case: matrix element option for Z0 decay to quarks.
9672       IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
9673      &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
9674
9675 C...Check consistency of MSTJ options set.
9676         IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
9677           CALL PYERRM(6,
9678      &    '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
9679           MSTJ(110)=1
9680         ENDIF
9681         IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
9682           CALL PYERRM(6,
9683      &    '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')
9684           MSTJ(111)=0
9685         ENDIF
9686
9687 C...Select alpha_strong behaviour.
9688         MST111=MSTU(111)
9689         PAR112=PARU(112)
9690         MSTU(111)=MSTJ(108)
9691         IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
9692      &  MSTU(111)=1
9693         PARU(112)=PARJ(121)
9694         IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
9695
9696 C...Find axial fraction in total cross section for scalar gluon model.
9697         PARJ(171)=0D0
9698         IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
9699      &  (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
9700           POLL=1D0-PARJ(131)*PARJ(132)
9701           SFF=1D0/(16D0*XW*XW1)
9702           SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
9703      &    (PARJ(123)*PARJ(124))**2)
9704           SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
9705           VE=4D0*XW-1D0
9706           HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
9707           HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
9708      &    (PARJ(132)-PARJ(131)))
9709           KFLC=IABS(KFL1(1))
9710           PMQ=PYMASS(KFLC)
9711           QF=KCHG(KFLC,1)/3D0
9712           VQ=1D0
9713           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
9714      &    1D0-(2D0*PMQ/P(ID,5))**2))
9715           VF=SIGN(1D0,QF)-4D0*QF*XW
9716           RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
9717      &    VF**2*HF1W)+VQ**3*HF1W
9718           IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
9719         ENDIF
9720
9721 C...Choice of jet configuration.
9722         CALL PYXJET(P(ID,5),NJET,CUT)
9723         KFLC=IABS(KFL1(1))
9724         KFLN=21
9725         IF(NJET.EQ.4) THEN
9726           CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
9727         ELSEIF(NJET.EQ.3) THEN
9728           CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
9729         ELSE
9730           MSTJ(120)=1
9731         ENDIF
9732
9733 C...Fill jet configuration; return if incorrect kinematics.
9734         NC=N-2
9735         IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
9736           CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
9737         ELSEIF(NJET.EQ.2) THEN
9738           CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
9739         ELSEIF(NJET.EQ.3) THEN
9740           CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
9741         ELSEIF(KFLN.EQ.21) THEN
9742           CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9743      &    X12,X14)
9744         ELSE
9745           CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
9746      &    X12,X14)
9747         ENDIF
9748         IF(MSTU(24).NE.0) THEN
9749           MINT(51)=1
9750           MSTU(111)=MST111
9751           PARU(112)=PAR112
9752           RETURN
9753         ENDIF
9754
9755 C...Angular orientation according to matrix element.
9756         IF(MSTJ(106).EQ.1) THEN
9757           CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI)
9758           IF(MINT(11).LT.0) THE=PARU(1)-THE
9759           CTHE(1)=COS(THE)
9760           CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
9761           CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
9762         ENDIF
9763
9764 C...Boost partons to Z0 rest frame.
9765         CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
9766      &  P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9767
9768 C...Mark decayed resonance and add documentation lines,
9769         K(ID,1)=K(ID,1)+10
9770         IDOC=MINT(83)+MINT(4)
9771         DO 240 I=NC+1,N
9772           I1=MINT(83)+MINT(4)+1
9773           K(I,3)=I1
9774           IF(MSTP(128).GE.1) K(I,3)=ID
9775           IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
9776             MINT(4)=MINT(4)+1
9777             K(I1,1)=21
9778             K(I1,2)=K(I,2)
9779             K(I1,3)=IREF(IP,4)
9780             DO 230 J=1,5
9781               P(I1,J)=P(I,J)
9782   230       CONTINUE
9783           ENDIF
9784   240   CONTINUE
9785
9786 C...Generate parton shower.
9787         IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5))
9788
9789 C... End special case for Z0: skip ahead.
9790         MSTU(111)=MST111
9791         PARU(112)=PAR112
9792         GOTO 550
9793       ENDIF
9794
9795 C...Order incoming partons and outgoing resonances.
9796       IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9797         ILIN(1)=MINT(84)+1
9798         IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
9799         IF(K(ILIN(1),2).EQ.21) ILIN(1)=2*MINT(84)+3-ILIN(1)
9800         ILIN(2)=2*MINT(84)+3-ILIN(1)
9801         IMIN=1
9802         IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
9803      &  .EQ.36) IMIN=3
9804         IMAX=2
9805         IORD=1
9806         IF(K(IREF(IP,1),2).EQ.23) IORD=2
9807         IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
9808         IAKIPD=IABS(K(IREF(IP,IORD),2))
9809         IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
9810         IF(KDCY(IORD).EQ.0) IORD=3-IORD
9811
9812 C...Order decay products of resonances.
9813         DO 250 JT=IORD,3-IORD,3-2*IORD
9814           IF(KDCY(JT).EQ.0) THEN
9815             ILIN(IMAX+1)=NSD(JT)
9816             IMAX=IMAX+1
9817           ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
9818             ILIN(IMAX+1)=N+2*JT-1
9819             ILIN(IMAX+2)=N+2*JT
9820             IMAX=IMAX+2
9821             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9822             K(N+2*JT,2)=K(NSD(JT)+2,2)
9823           ELSE
9824             ILIN(IMAX+1)=N+2*JT
9825             ILIN(IMAX+2)=N+2*JT-1
9826             IMAX=IMAX+2
9827             K(N+2*JT-1,2)=K(NSD(JT)+1,2)
9828             K(N+2*JT,2)=K(NSD(JT)+2,2)
9829           ENDIF
9830   250   CONTINUE
9831
9832 C...Find charge, isospin, left- and righthanded couplings.
9833         DO 270 I=IMIN,IMAX
9834           DO 260 J=1,4
9835             COUP(I,J)=0D0
9836   260     CONTINUE
9837           KFA=IABS(K(ILIN(I),2))
9838           IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270
9839           COUP(I,1)=KCHG(KFA,1)/3D0
9840           COUP(I,2)=(-1)**MOD(KFA,2)
9841           COUP(I,4)=-2D0*COUP(I,1)*XWV
9842           COUP(I,3)=COUP(I,2)+COUP(I,4)
9843   270   CONTINUE
9844
9845 C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
9846         IF(ISUB.EQ.22) THEN
9847           DO 300 I=3,5,2
9848             I1=IORD
9849             IF(I.EQ.5) I1=3-IORD
9850             DO 290 J1=1,2
9851               DO 280 J2=1,2
9852                 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
9853      &          16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
9854      &          COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
9855      &          COUP(I,J2+2)**2
9856   280         CONTINUE
9857   290       CONTINUE
9858   300     CONTINUE
9859           COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
9860      &    (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
9861           COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
9862      &    (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
9863           IF(COWT12.LT.PYR(0)*COMX12) GOTO 140
9864         ENDIF
9865       ENDIF
9866
9867 C...Select angular orientation type - Z'/W' only.
9868       MZPWP=0
9869       IF(ISUB.EQ.141) THEN
9870         IF(PYR(0).LT.PARU(130)) MZPWP=1
9871         IF(IP.EQ.2) THEN
9872           IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
9873           IAKIR=IABS(K(IREF(2,2),2))
9874           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9875         ENDIF
9876         IF(IP.GE.3) MZPWP=2
9877       ELSEIF(ISUB.EQ.142) THEN
9878         IF(PYR(0).LT.PARU(136)) MZPWP=1
9879         IF(IP.EQ.2) THEN
9880           IAKIR=IABS(K(IREF(2,2),2))
9881           IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
9882         ENDIF
9883         IF(IP.GE.3) MZPWP=2
9884       ENDIF
9885
9886 C...Select random angles (begin of weighting procedure).
9887   310 DO 320 JT=1,JTMAX
9888         IF(KDCY(JT).EQ.0) GOTO 320
9889         IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
9890           CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
9891           IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
9892           PHI(JT)=VINT(24)
9893         ELSE
9894           CTHE(JT)=2D0*PYR(0)-1D0
9895           PHI(JT)=PARU(2)*PYR(0)
9896         ENDIF
9897   320 CONTINUE
9898
9899       IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
9900 C...Construct massless four-vectors.
9901         DO 340 I=N+1,N+4
9902           K(I,1)=1
9903           DO 330 J=1,5
9904             P(I,J)=0D0
9905             V(I,J)=0D0
9906   330     CONTINUE
9907   340   CONTINUE
9908         DO 350 JT=1,JTMAX
9909           IF(KDCY(JT).EQ.0) GOTO 350
9910           ID=IREF(IP,JT)
9911           P(N+2*JT-1,3)=0.5D0*P(ID,5)
9912           P(N+2*JT-1,4)=0.5D0*P(ID,5)
9913           P(N+2*JT,3)=-0.5D0*P(ID,5)
9914           P(N+2*JT,4)=0.5D0*P(ID,5)
9915           CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
9916      &    P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
9917   350   CONTINUE
9918
9919 C...Store incoming and outgoing momenta, with random rotation to
9920 C...avoid accidental zeroes in HA expressions.
9921         DO 370 I=1,IMAX
9922           K(N+4+I,1)=1
9923           P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
9924      &    P(ILIN(I),3)**2+P(ILIN(I),5)**2)
9925           P(N+4+I,5)=P(ILIN(I),5)
9926           DO 360 J=1,3
9927             P(N+4+I,J)=P(ILIN(I),J)
9928   360     CONTINUE
9929   370   CONTINUE
9930   380   THERR=ACOS(2D0*PYR(0)-1D0)
9931         PHIRR=PARU(2)*PYR(0)
9932         CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
9933         DO 400 I=1,IMAX
9934           IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380
9935           DO 390 J=1,4
9936             PK(I,J)=P(N+4+I,J)
9937   390     CONTINUE
9938   400   CONTINUE
9939
9940 C...Calculate internal products.
9941         IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
9942      &  ISUB.EQ.142) THEN
9943           DO 420 I1=IMIN,IMAX-1
9944             DO 410 I2=I1+1,IMAX
9945               HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
9946      &        PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
9947      &        CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
9948      &        SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
9949      &        (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
9950      &        CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
9951               HC(I1,I2)=CONJG(HA(I1,I2))
9952               IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
9953               IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
9954               HA(I2,I1)=-HA(I1,I2)
9955               HC(I2,I1)=-HC(I1,I2)
9956   410       CONTINUE
9957   420     CONTINUE
9958         ENDIF
9959         DO 440 I=1,2
9960           DO 430 J=1,4
9961             PK(I,J)=-PK(I,J)
9962   430     CONTINUE
9963   440   CONTINUE
9964         DO 460 I1=IMIN,IMAX-1
9965           DO 450 I2=I1+1,IMAX
9966             PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
9967      &      PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
9968             PKK(I2,I1)=PKK(I1,I2)
9969   450     CONTINUE
9970   460   CONTINUE
9971       ENDIF
9972
9973       KFAGM=IABS(IREF(IP,7))
9974       IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
9975 C...Isotropic decay selected by user.
9976         WT=1D0
9977         WTMAX=1D0
9978
9979       ELSEIF(JTMAX.EQ.3) THEN
9980 C...Isotropic decay when three mother particles.
9981         WT=1D0
9982         WTMAX=1D0
9983
9984       ELSEIF(IT4.GE.1) THEN
9985 C... Isotropic decay t -> b + W etc for 4th generation q and l.
9986         WT=1D0
9987         WTMAX=1D0
9988
9989       ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
9990      &  IREF(IP,7).EQ.36) THEN
9991 C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
9992         IF(IP.EQ.1) WTMAX=SH**2
9993         IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
9994         KFA=IABS(K(IREF(IP,1),2))
9995         IF(KFA.EQ.23) THEN
9996           KFLF1A=IABS(KFL1(1))
9997           EF1=KCHG(KFLF1A,1)/3D0
9998           AF1=SIGN(1D0,EF1+0.1D0)
9999           VF1=AF1-4D0*EF1*XWV
10000           KFLF2A=IABS(KFL1(2))
10001           EF2=KCHG(KFLF2A,1)/3D0
10002           AF2=SIGN(1D0,EF2+0.1D0)
10003           VF2=AF2-4D0*EF2*XWV
10004           VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
10005           WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
10006      &    8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
10007         ELSEIF(KFA.EQ.24) THEN
10008           WT=16D0*PKK(3,5)*PKK(4,6)
10009         ELSE
10010           WT=WTMAX
10011         ENDIF
10012
10013       ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
10014      &  KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
10015      &  THEN
10016 C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
10017         I1=IREF(IP,8)
10018         IF(MOD(KFAGM,2).EQ.0) THEN
10019           I2=N+1
10020           I3=N+2
10021         ELSE
10022           I2=N+2
10023           I3=N+1
10024         ENDIF
10025         I4=IREF(IP,2)
10026         WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
10027      &  P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
10028      &  P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
10029         WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
10030
10031       ELSEIF(ISUB.EQ.1) THEN
10032 C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
10033         EI=KCHG(IABS(MINT(15)),1)/3D0
10034         AI=SIGN(1D0,EI+0.1D0)
10035         VI=AI-4D0*EI*XWV
10036         EF=KCHG(IABS(KFL1(1)),1)/3D0
10037         AF=SIGN(1D0,EF+0.1D0)
10038         VF=AF-4D0*EF*XWV
10039         RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
10040         WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10041      &  (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
10042         WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10043      &  (VI**2+AI**2)*VINT(114)*VF**2)
10044         WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
10045      &  4D0*VI*AI*VINT(114)*VF*AF)
10046         WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
10047      &  2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
10048         WTMAX=2D0*(WT1+ABS(WT3))
10049
10050       ELSEIF(ISUB.EQ.2) THEN
10051 C...Angular weight for W+/- -> 2 quarks/leptons.
10052         WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2
10053         WTMAX=4D0
10054
10055       ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
10056 C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
10057 C...-> gluon/gamma + 2 quarks/leptons.
10058         CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10059      &  COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10060      &  COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10061         CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10062      &  COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10063      &  COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10064         CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10065      &  COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10066      &  COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10067         CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10068      &  COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10069      &  COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10070         WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
10071      &  (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
10072         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10073      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
10074
10075       ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
10076 C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
10077 C...-> gluon/gamma + 2 quarks/leptons.
10078         WT=PKK(1,3)**2+PKK(2,4)**2
10079         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
10080
10081       ELSEIF(ISUB.EQ.22) THEN
10082 C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
10083         S34=P(IREF(IP,IORD),5)**2
10084         S56=P(IREF(IP,3-IORD),5)**2
10085         TI=PKK(1,3)+PKK(1,4)+S34
10086         UI=PKK(1,5)+PKK(1,6)+S56
10087         TIR=REAL(TI)
10088         UIR=REAL(UI)
10089         FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
10090         FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
10091         FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
10092         FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
10093         FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
10094         FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
10095         FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
10096         FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
10097         WT=
10098      &  CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
10099      &  CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
10100      &  CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
10101      &  CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
10102         WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
10103      &  (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
10104      &  ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
10105      &  1D0/UI**2))
10106
10107       ELSEIF(ISUB.EQ.23) THEN
10108 C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
10109         D34=P(IREF(IP,IORD),5)**2
10110         D56=P(IREF(IP,3-IORD),5)**2
10111         DT=PKK(1,3)+PKK(1,4)+D34
10112         DU=PKK(1,5)+PKK(1,6)+D56
10113         FACBW=1D0/((SH-SQMW)**2+SQMW*PMAS(24,2)**2)
10114         CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10115         CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
10116         FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
10117      &  REAL(CBWZ)*FGK(1,2,5,6,3,4))
10118         FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
10119      &  REAL(CBWZ)*FGK(1,2,6,5,3,4))
10120         WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10121         WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
10122      &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
10123
10124       ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
10125 C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
10126 C...(or H0, or A0).
10127         WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
10128      &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
10129      &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
10130         WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
10131      &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10132
10133       ELSEIF(ISUB.EQ.25) THEN
10134 C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
10135         D34=P(IREF(IP,IORD),5)**2
10136         D56=P(IREF(IP,3-IORD),5)**2
10137         DT=PKK(1,3)+PKK(1,4)+D34
10138         DU=PKK(1,5)+PKK(1,6)+D56
10139         FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
10140         CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
10141         CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
10142         CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
10143         CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
10144         FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
10145      &  REAL(CBWW)*FGK(1,2,5,6,3,4))
10146         FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10147         WT=FGK135**2+(CCWW*FGK253)**2
10148         WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-CAWW*
10149      &  CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
10150
10151       ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
10152 C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
10153 C...(or H0, or A0).
10154         WT=PKK(1,3)*PKK(2,4)
10155         WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
10156
10157       ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
10158 C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
10159 C...-> f + 2 quarks/leptons.
10160         CLILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10161      &  COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10162      &  COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2
10163         CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10164      &  COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10165      &  COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2
10166         CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10167      &  COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+
10168      &  COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2
10169         CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+
10170      &  COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+
10171      &  COUP(1,4)**2*HGZ(2,3)*COUP(3,4)**2
10172         IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
10173      &  PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
10174         IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
10175      &  PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
10176         WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
10177      &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
10178
10179       ELSEIF(ISUB.EQ.31) THEN
10180 C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.
10181         IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
10182         IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
10183         WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
10184
10185       ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
10186      &  ISUB.EQ.77) THEN
10187 C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
10188         WT=16D0*PKK(3,5)*PKK(4,6)
10189         WTMAX=SH**2
10190
10191       ELSEIF(ISUB.EQ.110) THEN
10192 C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
10193         WT=1D0
10194         WTMAX=1D0
10195
10196       ELSEIF(ISUB.EQ.141) THEN
10197         IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10198 C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
10199 C...Couplings of incoming flavour.
10200           KFAI=IABS(MINT(15))
10201           EI=KCHG(KFAI,1)/3D0
10202           AI=SIGN(1D0,EI+0.1D0)
10203           VI=AI-4D0*EI*XWV
10204           KFAIC=1
10205           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
10206           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
10207           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
10208           VPI=PARU(119+2*KFAIC)
10209           API=PARU(120+2*KFAIC)
10210 C...Couplings of final flavour.
10211           KFAF=IABS(KFL1(1))
10212           EF=KCHG(KFAF,1)/3D0
10213           AF=SIGN(1D0,EF+0.1D0)
10214           VF=AF-4D0*EF*XWV
10215           KFAFC=1
10216           IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
10217           IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
10218           IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
10219           VPF=PARU(119+2*KFAFC)
10220           APF=PARU(120+2*KFAFC)
10221 C...Asymmetry and weight.
10222           ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
10223      &    4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
10224      &    (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
10225      &    (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
10226      &    EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
10227      &    (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
10228      &    (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
10229           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10230           WTMAX=2D0+ABS(ASYM)
10231         ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
10232 C...Angular weight for f + fbar -> Z' -> W+ + W-.
10233           RM1=P(NSD(1)+1,5)**2/SH
10234           RM2=P(NSD(1)+2,5)**2/SH
10235           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10236      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10237           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10238      &    (RM2-RM1)**2)
10239           WT=CFLAT+CCOS2*CTHE(1)**2
10240           WTMAX=CFLAT+MAX(0D0,CCOS2)
10241         ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
10242      &    IABS(KFL1(1)).EQ.37)) THEN
10243 C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
10244           WT=1D0-CTHE(1)**2
10245           WTMAX=1D0
10246         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10247 C...Angular weight for f + fbar -> Z' -> Z0 + h0.
10248           RM1=P(NSD(1)+1,5)**2/SH
10249           RM2=P(NSD(1)+2,5)**2/SH
10250           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10251           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10252           WTMAX=1D0+FLAM2/(8D0*RM1)
10253         ELSEIF(MZPWP.EQ.0) THEN
10254 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10255 C...(W:s like if intermediate Z).
10256           D34=P(IREF(IP,IORD),5)**2
10257           D56=P(IREF(IP,3-IORD),5)**2
10258           DT=PKK(1,3)+PKK(1,4)+D34
10259           DU=PKK(1,5)+PKK(1,6)+D56
10260           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10261           FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
10262           WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
10263           WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
10264      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10265         ELSEIF(MZPWP.EQ.1) THEN
10266 C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
10267 C...(W:s approximately longitudinal, like if intermediate H).
10268           WT=16D0*PKK(3,5)*PKK(4,6)
10269           WTMAX=SH**2
10270         ELSE
10271 C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
10272 C...H0 + A0 -> 4 quarks/leptons.
10273           WT=1D0
10274           WTMAX=1D0
10275         ENDIF
10276
10277       ELSEIF(ISUB.EQ.142) THEN
10278         IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
10279 C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
10280           KFAI=IABS(MINT(15))
10281           KFAIC=1
10282           IF(KFAI.GT.10) KFAIC=2
10283           VI=PARU(129+2*KFAIC)
10284           AI=PARU(130+2*KFAIC)
10285           KFAF=IABS(KFL1(1))
10286           KFAFC=1
10287           IF(KFAF.GT.10) KFAFC=2
10288           VF=PARU(129+2*KFAFC)
10289           AF=PARU(130+2*KFAFC)
10290           ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
10291           WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
10292           WTMAX=2D0+ABS(ASYM)
10293         ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
10294 C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
10295           RM1=P(NSD(1)+1,5)**2/SH
10296           RM2=P(NSD(1)+2,5)**2/SH
10297           CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
10298      &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
10299           CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
10300      &    (RM2-RM1)**2)
10301           WT=CFLAT+CCOS2*CTHE(1)**2
10302           WTMAX=CFLAT+MAX(0D0,CCOS2)
10303         ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
10304 C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
10305           RM1=P(NSD(1)+1,5)**2/SH
10306           RM2=P(NSD(1)+2,5)**2/SH
10307           FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
10308           WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
10309           WTMAX=1D0+FLAM2/(8D0*RM1)
10310         ELSEIF(MZPWP.EQ.0) THEN
10311 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10312 C...(W/Z like if intermediate W).
10313           D34=P(IREF(IP,IORD),5)**2
10314           D56=P(IREF(IP,3-IORD),5)**2
10315           DT=PKK(1,3)+PKK(1,4)+D34
10316           DU=PKK(1,5)+PKK(1,6)+D56
10317           FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
10318           FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
10319           WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
10320           WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
10321      &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
10322         ELSEIF(MZPWP.EQ.1) THEN
10323 C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
10324 C...(W/Z approximately longitudinal, like if intermediate H).
10325           WT=16D0*PKK(3,5)*PKK(4,6)
10326           WTMAX=SH**2
10327         ELSE
10328 C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.
10329           WT=1D0
10330           WTMAX=1D0
10331         ENDIF
10332
10333       ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
10334      &  THEN
10335 C...Isotropic decay of leptoquarks (assumed spin 0).
10336         WT=1D0
10337         WTMAX=1D0
10338
10339       ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10340 C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).
10341         SIDE=1D0
10342         IF(MINT(16).EQ.21) SIDE=-1D0
10343         IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
10344           WT=1D0+SIDE*CTHE(1)
10345           WTMAX=2D0
10346         ELSEIF(IP.EQ.1) THEN
10347           RM1=P(NSD(1)+1,5)**2/SH
10348           WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10349           WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
10350         ELSE
10351 C...W/Z decay assumed isotropic, since not known.
10352           WT=1D0
10353           WTMAX=1D0
10354         ENDIF
10355
10356       ELSEIF(ISUB.EQ.149) THEN
10357 C...Isotropic decay of techni-eta.
10358         WT=1D0
10359         WTMAX=1D0
10360
10361       ELSEIF(ISUB.EQ.191) THEN
10362         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10363 C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,
10364 C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.
10365           WT=1D0-CTHE(1)**2
10366           WTMAX=1D0
10367         ELSEIF(IP.EQ.1) THEN
10368 C...Angular weight for f + fbar -> rho_tech0 -> f fbar.
10369           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10370           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
10371           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10372           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10373           KFAI=IABS(MINT(15))
10374           EI=KCHG(KFAI,1)/3D0
10375           AI=SIGN(1D0,EI+0.1D0)
10376           VI=AI-4D0*EI*XWV
10377           VALI=0.5D0*(VI+AI)
10378           VARI=0.5D0*(VI-AI)
10379           ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
10380           ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
10381           KFAF=IABS(KFL1(1))
10382           EF=KCHG(KFAF,1)/3D0
10383           AF=SIGN(1D0,EF+0.1D0)
10384           VF=AF-4D0*EF*XWV
10385           VALF=0.5D0*(VF+AF)
10386           VARF=0.5D0*(VF-AF)
10387           ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
10388           ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
10389           ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
10390           AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
10391           WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
10392           WTMAX=4D0*MAX(ASAME,AFLIP)
10393         ELSE
10394 C...Isotropic decay of W/pi_tech produced in rho_tech decay.
10395           WT=1D0
10396           WTMAX=1D0
10397         ENDIF
10398
10399       ELSEIF(ISUB.EQ.192) THEN
10400         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10401 C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,
10402 C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.
10403           WT=1D0-CTHE(1)**2
10404           WTMAX=1D0
10405         ELSEIF(IP.EQ.1) THEN
10406 C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.
10407           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10408           WT=(1D0+CTHESG)**2
10409           WTMAX=4D0
10410         ELSE
10411 C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.
10412           WT=1D0
10413           WTMAX=1D0
10414         ENDIF
10415
10416       ELSEIF(ISUB.EQ.193) THEN
10417         IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
10418 C...Angular weight for f + fbar -> omega_tech0 ->
10419 C...gamma pi_tech0 or Z0 pi_tech0.
10420           WT=1D0+CTHE(1)**2
10421           WTMAX=2D0
10422         ELSEIF(IP.EQ.1) THEN
10423 C...Angular weight for f + fbar -> omega_tech0 -> f fbar.
10424           CTHESG=CTHE(1)*ISIGN(1,MINT(15))
10425           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
10426           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
10427           KFAI=IABS(MINT(15))
10428           EI=KCHG(KFAI,1)/3D0
10429           AI=SIGN(1D0,EI+0.1D0)
10430           VI=AI-4D0*EI*XWV
10431           VALI=0.5D0*(VI+AI)
10432           VARI=0.5D0*(VI-AI)
10433           BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
10434           BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
10435           KFAF=IABS(KFL1(1))
10436           EF=KCHG(KFAF,1)/3D0
10437           AF=SIGN(1D0,EF+0.1D0)
10438           VF=AF-4D0*EF*XWV
10439           VALF=0.5D0*(VF+AF)
10440           VARF=0.5D0*(VF-AF)
10441           BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
10442           BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
10443           BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
10444           BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
10445           WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
10446           WTMAX=4D0*MAX(BSAME,BFLIP)
10447         ELSE
10448 C...Isotropic decay of Z/pi_tech produced in omega_tech decay.
10449           WT=1D0
10450           WTMAX=1D0
10451         ENDIF
10452
10453 C...Obtain correct angular distribution by rejection techniques.
10454       ELSE
10455         WT=1D0
10456         WTMAX=1D0
10457       ENDIF
10458       IF(WT.LT.PYR(0)*WTMAX) GOTO 310
10459
10460 C...Construct massive four-vectors using angles chosen.
10461   470 DO 540 JT=1,JTMAX
10462         IF(KDCY(JT).EQ.0) GOTO 540
10463         ID=IREF(IP,JT)
10464         DO 480 J=1,5
10465           DPMO(J)=P(ID,J)
10466   480   CONTINUE
10467         DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
10468 CMRENNA++
10469         IF(KFL3(JT).EQ.0) THEN
10470           CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
10471      &    DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10472         ELSE
10473           CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
10474      &    DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
10475         ENDIF
10476 CMRENNA--
10477
10478 C...Mark decayed resonances; trace history.
10479         K(ID,1)=K(ID,1)+10
10480         KFA=IABS(K(ID,2))
10481         KCA=PYCOMP(KFA)
10482         IF(KCQM(JT).NE.0) THEN
10483 C...Do not kill colour flow through coloured resonance!
10484         ELSE
10485           K(ID,4)=NSD(JT)+1
10486           K(ID,5)=NSD(JT)+2
10487           IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3
10488         ENDIF
10489
10490 C...Add documentation lines.
10491         IF(ISUB.NE.0) THEN
10492           IDOC=MINT(83)+MINT(4)
10493 CMRENNA+++
10494           IHI=NSD(JT)+2
10495           IF(KFL3(JT).NE.0) IHI=IHI+1
10496           DO 500 I=NSD(JT)+1,IHI
10497 CMRENNA---
10498             I1=MINT(83)+MINT(4)+1
10499             K(I,3)=I1
10500             IF(MSTP(128).GE.1) K(I,3)=ID
10501             IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
10502               MINT(4)=MINT(4)+1
10503               K(I1,1)=21
10504               K(I1,2)=K(I,2)
10505               K(I1,3)=IREF(IP,JT+3)
10506               DO 490 J=1,5
10507                 P(I1,J)=P(I,J)
10508   490         CONTINUE
10509             ENDIF
10510   500     CONTINUE
10511         ELSE
10512           K(NSD(JT)+1,3)=ID
10513           K(NSD(JT)+2,3)=ID
10514           IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID
10515         ENDIF
10516
10517 C...Do showering if any of the two/three products can shower.
10518         NSHBEF=N
10519         IF(MSTP(71).GE.1) THEN
10520           ISHOW1=0
10521           KFL1A=IABS(KFL1(JT))
10522           IF(KFL1A.LE.22) ISHOW1=1
10523           ISHOW2=0
10524           KFL2A=IABS(KFL2(JT))
10525           IF(KFL2A.LE.22) ISHOW2=1
10526           ISHOW3=0
10527           IF(KFL3(JT).NE.0) THEN
10528             KFL3A=IABS(KFL3(JT))
10529             IF(KFL3A.LE.22) ISHOW3=1
10530           ENDIF
10531           IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN
10532           ELSEIF(KFL3(JT).EQ.0) THEN
10533             CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
10534           ELSE
10535             NSD1=NSD(JT)+1
10536             NSD2=NSD(JT)+2
10537             IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN
10538               NSD1=NSD(JT)+3
10539             ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN
10540               NSD2=NSD(JT)+3
10541             ENDIF
10542             PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2-
10543      &      (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2-
10544      &      (P(NSD1,3)+P(NSD2,3))**2))
10545             CALL PYSHOW(NSD1,NSD2,PMSHOW)
10546           ENDIF
10547         ENDIF
10548         NSHAFT=N
10549         IF(JT.EQ.1) NAFT1=N
10550
10551 C...Check if decay products moved by shower.
10552         NSD1=NSD(JT)+1
10553         NSD2=NSD(JT)+2
10554         NSD3=NSD(JT)+3
10555         IF(NSHAFT.GT.NSHBEF) THEN
10556           IF(K(NSD1,1).GT.10) THEN
10557             DO 510 I=NSHBEF+1,NSHAFT
10558               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
10559   510       CONTINUE
10560           ENDIF
10561           IF(K(NSD2,1).GT.10) THEN
10562             DO 520 I=NSHBEF+1,NSHAFT
10563               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
10564      &        I.NE.NSD1) NSD2=I
10565   520       CONTINUE
10566           ENDIF
10567           IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
10568             DO 530 I=NSHBEF+1,NSHAFT
10569               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
10570      &        I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
10571   530       CONTINUE
10572           ENDIF
10573         ENDIF
10574
10575 C...Store decay products for further treatment.
10576         NP=NP+1
10577         IREF(NP,1)=NSD1
10578         IREF(NP,2)=NSD2
10579         IREF(NP,3)=0
10580         IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
10581         IREF(NP,4)=IDOC+1
10582         IREF(NP,5)=IDOC+2
10583         IREF(NP,6)=0
10584         IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
10585         IREF(NP,7)=K(IREF(IP,JT),2)
10586         IREF(NP,8)=IREF(IP,JT)
10587   540 CONTINUE
10588
10589 C...Fill information for 2 -> 1 -> 2.
10590   550 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
10591         MINT(7)=MINT(83)+6+2*ISET(ISUB)
10592         MINT(8)=MINT(83)+7+2*ISET(ISUB)
10593         MINT(25)=KFL1(1)
10594         MINT(26)=KFL2(1)
10595         VINT(23)=CTHE(1)
10596         RM3=P(N-1,5)**2/SH
10597         RM4=P(N,5)**2/SH
10598         BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
10599         VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
10600         VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
10601         VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
10602         VINT(47)=SQRT(VINT(48))
10603       ENDIF
10604
10605 C...Possibility of colour rearrangement in W+W- events.
10606       IF(ISUB.EQ.25.AND.MSTP(115).GE.1) THEN
10607         IAKF1=IABS(KFL1(1))
10608         IAKF2=IABS(KFL1(2))
10609         IAKF3=IABS(KFL2(1))
10610         IAKF4=IABS(KFL2(2))
10611         IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
10612      &  MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
10613      &  PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
10614       ENDIF
10615
10616 C...Loop back if needed.
10617   560 IF(IP.LT.NP) GOTO 130
10618
10619       RETURN
10620       END
10621
10622 C*********************************************************************
10623
10624 *$ CREATE PYMULT.FOR
10625 *COPY PYMULT
10626 C...PYMULT
10627 C...Initializes treatment of multiple interactions, selects kinematics
10628 C...of hardest interaction if low-pT physics included in run, and
10629 C...generates all non-hardest interactions.
10630
10631       SUBROUTINE PYMULT(MMUL)
10632
10633 C...Double precision and integer declarations.
10634       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10635       INTEGER PYK,PYCHGE,PYCOMP
10636 C...Commonblocks.
10637       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10638       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10639       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10640       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10641       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10642       COMMON/PYINT1/MINT(400),VINT(400)
10643       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10644       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10645       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10646       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
10647       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
10648      &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
10649 C...Local arrays and saved variables.
10650       DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
10651       SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM
10652
10653 C...Initialization of multiple interaction treatment.
10654       IF(MMUL.EQ.1) THEN
10655         IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
10656         ISUB=96
10657         MINT(1)=96
10658         VINT(63)=0D0
10659         VINT(64)=0D0
10660         VINT(143)=1D0
10661         VINT(144)=1D0
10662
10663 C...Loop over phase space points: xT2 choice in 20 bins.
10664   100   SIGSUM=0D0
10665         DO 120 IXT2=1,20
10666           NMUL(IXT2)=MSTP(83)
10667           SIGM(IXT2)=0D0
10668           DO 110 ITRY=1,MSTP(83)
10669             RSCA=0.05D0*((21-IXT2)-PYR(0))
10670             XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
10671             XT2=MAX(0.01D0*VINT(149),XT2)
10672             VINT(25)=XT2
10673
10674 C...Choose tau and y*. Calculate cos(theta-hat).
10675             IF(PYR(0).LE.COEF(ISUB,1)) THEN
10676               TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10677               TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10678             ELSE
10679               TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10680             ENDIF
10681             VINT(21)=TAU
10682             CALL PYKLIM(2)
10683             RYST=PYR(0)
10684             MYST=1
10685             IF(RYST.GT.COEF(ISUB,8)) MYST=2
10686             IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10687             CALL PYKMAP(2,MYST,PYR(0))
10688             VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10689
10690 C...Calculate differential cross-section.
10691             VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10692             CALL PYSIGH(NCHN,SIGS)
10693             SIGM(IXT2)=SIGM(IXT2)+SIGS
10694   110     CONTINUE
10695           SIGSUM=SIGSUM+SIGM(IXT2)
10696   120   CONTINUE
10697         SIGSUM=SIGSUM/(20D0*MSTP(83))
10698
10699 C...Reject result if sigma(parton-parton) is smaller than hadronic one.
10700         IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
10701           IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) PARP(82),SIGSUM
10702           PARP(82)=0.9D0*PARP(82)
10703           VINT(149)=4D0*PARP(82)**2/VINT(2)
10704           GOTO 100
10705         ENDIF
10706         IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM
10707
10708 C...Start iteration to find k factor.
10709         YKE=SIGSUM/SIGT(0,0,5)
10710         SO=0.5D0
10711         XI=0D0
10712         YI=0D0
10713         XF=0D0
10714         YF=0D0
10715         XK=0.5D0
10716         IIT=0
10717   130   IF(IIT.EQ.0) THEN
10718           XK=2D0*XK
10719         ELSEIF(IIT.EQ.1) THEN
10720           XK=0.5D0*XK
10721         ELSE
10722           XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
10723         ENDIF
10724
10725 C...Evaluate overlap integrals.
10726         IF(MSTP(82).EQ.2) THEN
10727           SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
10728           SOP=SP/PARU(1)
10729         ELSE
10730           IF(MSTP(82).EQ.3) DELTAB=0.02D0
10731           IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84))
10732           SP=0D0
10733           SOP=0D0
10734           B=-0.5D0*DELTAB
10735   140     B=B+DELTAB
10736           IF(MSTP(82).EQ.3) THEN
10737             OV=EXP(-B**2)/PARU(2)
10738           ELSE
10739             CQ2=PARP(84)**2
10740             OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+
10741      &      2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)*
10742      &      EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+
10743      &      PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2)
10744           ENDIF
10745           PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
10746           SP=SP+PARU(2)*B*DELTAB*PACC
10747           SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
10748           IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
10749         ENDIF
10750         YK=PARU(1)*XK*SO/SP
10751
10752 C...Continue iteration until convergence.
10753         IF(YK.LT.YKE) THEN
10754           XI=XK
10755           YI=YK
10756           IF(IIT.EQ.1) IIT=2
10757         ELSE
10758           XF=XK
10759           YF=YK
10760           IF(IIT.EQ.0) IIT=1
10761         ENDIF
10762         IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
10763
10764 C...Store some results for subsequent use.
10765         VINT(145)=SIGSUM
10766         VINT(146)=SOP/SO
10767         VINT(147)=SOP/SP
10768
10769 C...Initialize iteration in xT2 for hardest interaction.
10770       ELSEIF(MMUL.EQ.2) THEN
10771         IF(MSTP(82).LE.0) THEN
10772         ELSEIF(MSTP(82).EQ.1) THEN
10773           XT2=1D0
10774           XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149))
10775         ELSEIF(MSTP(82).EQ.2) THEN
10776           XT2=1D0
10777           XT2FAC=VINT(146)*XSEC(96,1)/SIGT(0,0,5)*VINT(149)*
10778      &    (1D0+VINT(149))
10779         ELSE
10780           XC2=4D0*CKIN(3)**2/VINT(2)
10781           IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
10782         ENDIF
10783
10784       ELSEIF(MMUL.EQ.3) THEN
10785 C...Low-pT or multiple interactions (first semihard interaction):
10786 C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
10787 C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
10788         ISUB=MINT(1)
10789         IF(MSTP(82).LE.0) THEN
10790           XT2=0D0
10791         ELSEIF(MSTP(82).EQ.1) THEN
10792           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10793         ELSEIF(MSTP(82).EQ.2) THEN
10794           IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
10795      &    VINT(149)))).GT.PYR(0)) XT2=1D0
10796           IF(XT2.GE.1D0) THEN
10797             XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
10798      &      PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
10799      &      VINT(149)
10800           ELSE
10801             XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
10802      &      (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
10803      &      VINT(149)
10804           ENDIF
10805           XT2=MAX(0.01D0*VINT(149),XT2)
10806         ELSE
10807           XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
10808      &    PYR(0)*(1D0-XC2))-VINT(149)
10809           XT2=MAX(0.01D0*VINT(149),XT2)
10810         ENDIF
10811         VINT(25)=XT2
10812
10813 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
10814         IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
10815           IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-1
10816           IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1
10817           ISUB=95
10818           MINT(1)=ISUB
10819           VINT(21)=0.01D0*VINT(149)
10820           VINT(22)=0D0
10821           VINT(23)=0D0
10822           VINT(25)=0.01D0*VINT(149)
10823
10824         ELSE
10825 C...Multiple interactions (first semihard interaction).
10826 C...Choose tau and y*. Calculate cos(theta-hat).
10827           IF(PYR(0).LE.COEF(ISUB,1)) THEN
10828             TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10829             TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10830           ELSE
10831             TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10832           ENDIF
10833           VINT(21)=TAU
10834           CALL PYKLIM(2)
10835           RYST=PYR(0)
10836           MYST=1
10837           IF(RYST.GT.COEF(ISUB,8)) MYST=2
10838           IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10839           CALL PYKMAP(2,MYST,PYR(0))
10840           VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10841         ENDIF
10842         VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
10843
10844 C...Store results of cross-section calculation.
10845       ELSEIF(MMUL.EQ.4) THEN
10846         ISUB=MINT(1)
10847         XTS=VINT(25)
10848         IF(ISET(ISUB).EQ.1) XTS=VINT(21)
10849         IF(ISET(ISUB).EQ.2)
10850      &  XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10851         IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
10852         RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
10853      &  (XTS+VINT(149))))
10854         IRBIN=INT(1D0+20D0*RBIN)
10855         IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
10856           NMUL(IRBIN)=NMUL(IRBIN)+1
10857           SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
10858         ENDIF
10859
10860 C...Choose impact parameter.
10861       ELSEIF(MMUL.EQ.5) THEN
10862         IF(MSTP(82).EQ.3) THEN
10863           VINT(148)=PYR(0)/(PARU(2)*VINT(147))
10864         ELSE
10865           RTYPE=PYR(0)
10866           CQ2=PARP(84)**2
10867           IF(RTYPE.LT.(1D0-PARP(83))**2) THEN
10868             B2=-LOG(PYR(0))
10869           ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN
10870             B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0))
10871           ELSE
10872             B2=-CQ2*LOG(PYR(0))
10873           ENDIF
10874           VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)*
10875      &    (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+
10876      &    PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147))
10877         ENDIF
10878
10879 C...Multiple interactions (variable impact parameter) : reject with
10880 C...probability exp(-overlap*cross-section above pT/normalization).
10881         RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
10882         SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
10883         DO 150 IBIN=IRBIN+1,20
10884           RNCOR=RNCOR+NMUL(IBIN)
10885           SIGCOR=SIGCOR+SIGM(IBIN)
10886   150   CONTINUE
10887         SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
10888         IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
10889         VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)*
10890      &  SIGABV/SIGT(0,0,5)))
10891
10892 C...Generate additional multiple semihard interactions.
10893       ELSEIF(MMUL.EQ.6) THEN
10894         ISUBSV=MINT(1)
10895         DO 160 J=11,80
10896           VINTSV(J)=VINT(J)
10897   160   CONTINUE
10898         ISUB=96
10899         MINT(1)=96
10900
10901 C...Reconstruct strings in hard scattering.
10902         NMAX=MINT(84)+4
10903         IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
10904         IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
10905         NSTR=0
10906         DO 180 I=MINT(84)+1,NMAX
10907           KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
10908           IF(KCS.EQ.0) GOTO 180
10909
10910           DO 170 J=1,4
10911             IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170
10912             IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170
10913             IF(J.LE.2) THEN
10914               IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
10915             ELSE
10916               IST=MOD(K(I,J+1),MSTU(5))
10917             ENDIF
10918             IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 170
10919             IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170
10920             NSTR=NSTR+1
10921             IF(J.EQ.1.OR.J.EQ.4) THEN
10922               KSTR(NSTR,1)=I
10923               KSTR(NSTR,2)=IST
10924             ELSE
10925               KSTR(NSTR,1)=IST
10926               KSTR(NSTR,2)=I
10927             ENDIF
10928   170     CONTINUE
10929   180   CONTINUE
10930
10931 C...Set up starting values for iteration in xT2.
10932         XT2=VINT(25)
10933         IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
10934         IF(ISET(ISUBSV).EQ.2)
10935      &  XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
10936         IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
10937         IF(MSTP(82).LE.1) THEN
10938           XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5))
10939         ELSE
10940           XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/SIGT(0,0,5)*
10941      &    VINT(149)*(1D0+VINT(149))
10942         ENDIF
10943         VINT(63)=0D0
10944         VINT(64)=0D0
10945         VINT(143)=1D0-VINT(141)
10946         VINT(144)=1D0-VINT(142)
10947
10948 C...Iterate downwards in xT2.
10949   190   IF(MSTP(82).LE.1) THEN
10950           XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
10951           IF(XT2.LT.VINT(149)) GOTO 240
10952         ELSE
10953           IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240
10954           XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
10955      &    LOG(PYR(0)))-VINT(149)
10956           IF(XT2.LE.0D0) GOTO 240
10957           XT2=MAX(0.01D0*VINT(149),XT2)
10958         ENDIF
10959         VINT(25)=XT2
10960
10961 C...Choose tau and y*. Calculate cos(theta-hat).
10962         IF(PYR(0).LE.COEF(ISUB,1)) THEN
10963           TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
10964           TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
10965         ELSE
10966           TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
10967         ENDIF
10968         VINT(21)=TAU
10969         CALL PYKLIM(2)
10970         RYST=PYR(0)
10971         MYST=1
10972         IF(RYST.GT.COEF(ISUB,8)) MYST=2
10973         IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10974         CALL PYKMAP(2,MYST,PYR(0))
10975         VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
10976
10977 C...Check that x not used up. Accept or reject kinematical variables.
10978         X1M=SQRT(TAU)*EXP(VINT(22))
10979         X2M=SQRT(TAU)*EXP(-VINT(22))
10980         IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 190
10981         VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
10982         CALL PYSIGH(NCHN,SIGS)
10983         IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190
10984
10985 C...Reset K, P and V vectors. Select some variables.
10986         DO 210 I=N+1,N+2
10987           DO 200 J=1,5
10988             K(I,J)=0
10989             P(I,J)=0D0
10990             V(I,J)=0D0
10991   200     CONTINUE
10992   210   CONTINUE
10993         RFLAV=PYR(0)
10994         PT=0.5D0*VINT(1)*SQRT(XT2)
10995         PHI=PARU(2)*PYR(0)
10996         CTH=VINT(23)
10997
10998 C...Add first parton to event record.
10999         K(N+1,1)=3
11000         K(N+1,2)=21
11001         IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
11002      &  1+INT((2D0+PARJ(2))*PYR(0))
11003         P(N+1,1)=PT*COS(PHI)
11004         P(N+1,2)=PT*SIN(PHI)
11005         P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
11006         P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
11007         P(N+1,5)=0D0
11008
11009 C...Add second parton to event record.
11010         K(N+2,1)=3
11011         K(N+2,2)=21
11012         IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
11013         P(N+2,1)=-P(N+1,1)
11014         P(N+2,2)=-P(N+1,2)
11015         P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
11016         P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
11017         P(N+2,5)=0D0
11018
11019         IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
11020 C....Choose relevant string pieces to place gluons on.
11021           DO 230 I=N+1,N+2
11022             DMIN=1D8
11023             DO 220 ISTR=1,NSTR
11024               I1=KSTR(ISTR,1)
11025               I2=KSTR(ISTR,2)
11026               DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
11027      &        P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
11028      &        P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
11029      &        P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
11030               IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
11031                 DMIN=DIST
11032                 IST1=I1
11033                 IST2=I2
11034                 ISTM=ISTR
11035               ENDIF
11036   220       CONTINUE
11037
11038 C....Colour flow adjustments, new string pieces.
11039             IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
11040      &      MOD(K(IST1,4),MSTU(5))
11041             IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
11042      &      MSTU(5)*(K(IST1,5)/MSTU(5))+I
11043             K(I,5)=MSTU(5)*IST1
11044             K(I,4)=MSTU(5)*IST2
11045             IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
11046      &      MOD(K(IST2,5),MSTU(5))
11047             IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
11048      &      MSTU(5)*(K(IST2,4)/MSTU(5))+I
11049             KSTR(ISTM,2)=I
11050             KSTR(NSTR+1,1)=I
11051             KSTR(NSTR+1,2)=IST2
11052             NSTR=NSTR+1
11053   230     CONTINUE
11054
11055 C...String drawing and colour flow for gluon loop.
11056         ELSEIF(K(N+1,2).EQ.21) THEN
11057           K(N+1,4)=MSTU(5)*(N+2)
11058           K(N+1,5)=MSTU(5)*(N+2)
11059           K(N+2,4)=MSTU(5)*(N+1)
11060           K(N+2,5)=MSTU(5)*(N+1)
11061           KSTR(NSTR+1,1)=N+1
11062           KSTR(NSTR+1,2)=N+2
11063           KSTR(NSTR+2,1)=N+2
11064           KSTR(NSTR+2,2)=N+1
11065           NSTR=NSTR+2
11066
11067 C...String drawing and colour flow for qqbar pair.
11068         ELSE
11069           K(N+1,4)=MSTU(5)*(N+2)
11070           K(N+2,5)=MSTU(5)*(N+1)
11071           KSTR(NSTR+1,1)=N+1
11072           KSTR(NSTR+1,2)=N+2
11073           NSTR=NSTR+1
11074         ENDIF
11075
11076 C...Update remaining energy; iterate.
11077         N=N+2
11078         IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
11079           CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
11080           IF(MSTU(21).GE.1) RETURN
11081         ENDIF
11082         MINT(31)=MINT(31)+1
11083         VINT(151)=VINT(151)+VINT(41)
11084         VINT(152)=VINT(152)+VINT(42)
11085         VINT(143)=VINT(143)-VINT(41)
11086         VINT(144)=VINT(144)-VINT(42)
11087         IF(MINT(31).LT.240) GOTO 190
11088   240   CONTINUE
11089         MINT(1)=ISUBSV
11090         DO 250 J=11,80
11091           VINT(J)=VINTSV(J)
11092   250   CONTINUE
11093       ENDIF
11094
11095 C...Format statements for printout.
11096  5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
11097      &'actions for MSTP(82) =',I2,' ******')
11098  5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11099      &D9.2,' mb: rejected')
11100  5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
11101      &D9.2,' mb: accepted')
11102
11103       RETURN
11104       END
11105
11106 C*********************************************************************
11107
11108 *$ CREATE PYREMN.FOR
11109 *COPY PYREMN
11110 C...PYREMN
11111 C...Adds on target remnants (one or two from each side) and
11112 C...includes primordial kT for hadron beams.
11113
11114       SUBROUTINE PYREMN(IPU1,IPU2)
11115
11116 C...Double precision and integer declarations.
11117       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11118       INTEGER PYK,PYCHGE,PYCOMP
11119 C...Commonblocks.
11120       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11121       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11122       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
11123       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11124       COMMON/PYINT1/MINT(400),VINT(400)
11125       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
11126 C...Local arrays.
11127       DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
11128      &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
11129
11130 C...Find event type and remaining energy.
11131       ISUB=MINT(1)
11132       NS=N
11133       IF(MINT(50).EQ.0.OR.MSTP(81).LE.0) THEN
11134         VINT(143)=1D0-VINT(141)
11135         VINT(144)=1D0-VINT(142)
11136       ENDIF
11137
11138 C...Define initial partons.
11139       NTRY=0
11140   100 NTRY=NTRY+1
11141       DO 130 JT=1,2
11142         I=MINT(83)+JT+2
11143         IF(JT.EQ.1) IPU=IPU1
11144         IF(JT.EQ.2) IPU=IPU2
11145         K(I,1)=21
11146         K(I,2)=K(IPU,2)
11147         K(I,3)=I-2
11148         PMS(JT)=0D0
11149         VINT(156+JT)=0D0
11150         VINT(158+JT)=0D0
11151         IF(MINT(47).EQ.1) THEN
11152           DO 110 J=1,5
11153             P(I,J)=P(I-2,J)
11154   110     CONTINUE
11155         ELSEIF(ISUB.EQ.95) THEN
11156           K(I,2)=21
11157         ELSE
11158           P(I,5)=P(IPU,5)
11159
11160 C...No primordial kT, or chosen according to truncated Gaussian or
11161 C...exponential, or (for photon) predetermined or power law.
11162   120     IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
11163             IF(MSTP(91).LE.0) THEN
11164               PT=0D0
11165             ELSEIF(MSTP(91).EQ.1) THEN
11166               PT=PARP(91)*SQRT(-LOG(PYR(0)))
11167             ELSE
11168               RPT1=PYR(0)
11169               RPT2=PYR(0)
11170               PT=-PARP(92)*LOG(RPT1*RPT2)
11171             ENDIF
11172             IF(PT.GT.PARP(93)) GOTO 120
11173           ELSEIF(MINT(106+JT).EQ.3) THEN
11174             PT=SQRT(VINT(282+JT))
11175             PT=PT*0.8D0**MINT(57)
11176             IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
11177           ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
11178             IF(MSTP(93).LE.0) THEN
11179               PT=0D0
11180             ELSEIF(MSTP(93).EQ.1) THEN
11181               PT=PARP(99)*SQRT(-LOG(PYR(0)))
11182             ELSEIF(MSTP(93).EQ.2) THEN
11183               RPT1=PYR(0)
11184               RPT2=PYR(0)
11185               PT=-PARP(99)*LOG(RPT1*RPT2)
11186             ELSEIF(MSTP(93).EQ.3) THEN
11187               HA=PARP(99)**2
11188               HB=PARP(100)**2
11189               PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
11190             ELSE
11191               HA=PARP(99)**2
11192               HB=PARP(100)**2
11193               IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
11194               PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
11195             ENDIF
11196             IF(PT.GT.PARP(100)) GOTO 120
11197           ELSE
11198             PT=0D0
11199           ENDIF
11200           VINT(156+JT)=PT
11201           PHI=PARU(2)*PYR(0)
11202           P(I,1)=PT*COS(PHI)
11203           P(I,2)=PT*SIN(PHI)
11204           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11205         ENDIF
11206   130 CONTINUE
11207       IF(MINT(47).EQ.1) RETURN
11208
11209 C...Kinematics construction for initial partons.
11210       I1=MINT(83)+3
11211       I2=MINT(83)+4
11212       IF(ISUB.EQ.95) THEN
11213         SHS=0D0
11214         SHR=0D0
11215       ELSE
11216         SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
11217      &  (P(I1,2)+P(I2,2))**2
11218         SHR=SQRT(MAX(0D0,SHS))
11219         IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
11220         P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
11221         P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
11222         P(I2,4)=SHR-P(I1,4)
11223         P(I2,3)=-P(I1,3)
11224
11225 C...Transform partons to overall CM-frame.
11226         ROBO(3)=(P(I1,1)+P(I2,1))/SHR
11227         ROBO(4)=(P(I1,2)+P(I2,2))/SHR
11228         CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
11229         ROBO(2)=PYANGL(P(I1,1),P(I1,2))
11230         CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
11231         ROBO(1)=PYANGL(P(I1,3),P(I1,1))
11232         CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
11233         CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
11234         ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(VINT(141)-VINT(142))/
11235      &  (VINT(141)+VINT(142))))
11236         CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
11237       ENDIF
11238
11239 C...Optionally fix up x and Q2 definitions for leptoproduction.
11240       IDISXQ=0
11241       IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
11242      &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
11243       IF(IDISXQ.EQ.1) THEN
11244
11245 C...Find where incoming and outgoing leptons/partons are sitting.
11246         LESD=1
11247         IF(MINT(42).EQ.1) LESD=2
11248         LPIN=MINT(83)+3-LESD
11249         LEIN=MINT(84)+LESD
11250         LQIN=MINT(84)+3-LESD
11251         LEOUT=MINT(84)+2+LESD
11252         LQOUT=MINT(84)+5-LESD
11253         IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
11254         IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
11255         LSCMS=0
11256         DO 140 I=MINT(84)+5,N
11257           IF(K(I,2).EQ.94) THEN
11258             LSCMS=I
11259             LEOUT=I+LESD
11260             LQOUT=I+3-LESD
11261           ENDIF
11262   140   CONTINUE
11263         LQBG=IPU1
11264         IF(LESD.EQ.1) LQBG=IPU2
11265
11266 C...Calculate actual and wanted momentum transfer.
11267         XNOM=VINT(43-LESD)
11268         Q2NOM=-VINT(45)
11269         HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
11270      &  P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
11271      &  (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
11272         HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
11273         FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
11274         P(N+1,1)=FAC*P(LEOUT,1)
11275         P(N+1,2)=FAC*P(LEOUT,2)
11276         P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
11277      &  Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
11278         P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
11279      &  P(N+1,3)**2)
11280         DO 150 J=1,4
11281           QOLD(J)=P(LEIN,J)-P(LEOUT,J)
11282           QNEW(J)=P(LEIN,J)-P(N+1,J)
11283   150   CONTINUE
11284
11285 C...Boost outgoing electron and daughters.
11286         IF(LSCMS.EQ.0) THEN
11287           DO 160 J=1,4
11288             P(LEOUT,J)=P(N+1,J)
11289   160     CONTINUE
11290         ELSE
11291           DO 170 J=1,3
11292             P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
11293   170     CONTINUE
11294           PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
11295           DO 180 J=1,3
11296             DBE(J)=PINV*P(N+2,J)
11297   180     CONTINUE
11298           DO 200 I=LSCMS+1,N
11299             IORIG=I
11300   190       IORIG=K(IORIG,3)
11301             IF(IORIG.GT.LEOUT) GOTO 190
11302             IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
11303      &      CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
11304   200     CONTINUE
11305         ENDIF
11306
11307 C...Copy shower initiator and all outgoing partons.
11308         NCOP=N+1
11309         K(NCOP,3)=LQBG
11310         DO 210 J=1,5
11311           P(NCOP,J)=P(LQBG,J)
11312   210   CONTINUE
11313         DO 240 I=MINT(84)+1,N
11314           ICOP=0
11315           IF(K(I,1).GT.10) GOTO 240
11316           IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
11317             ICOP=I
11318           ELSE
11319             IORIG=I
11320   220       IORIG=K(IORIG,3)
11321             IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
11322               ICOP=IORIG
11323             ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
11324               GOTO 220
11325             ENDIF
11326           ENDIF
11327           IF(ICOP.NE.0) THEN
11328             NCOP=NCOP+1
11329             K(NCOP,3)=I
11330             DO 230 J=1,5
11331               P(NCOP,J)=P(I,J)
11332   230       CONTINUE
11333           ENDIF
11334   240   CONTINUE
11335
11336 C...Calculate relative rescaling factors.
11337         SLC=3-2*LESD
11338         PLCSUM=0D0
11339         DO 250 I=N+2,NCOP
11340           PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
11341   250   CONTINUE
11342         DO 260 I=N+2,NCOP
11343           V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
11344   260   CONTINUE
11345
11346 C...Transfer extra three-momentum of current.
11347         DO 280 I=N+2,NCOP
11348           DO 270 J=1,3
11349             P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
11350   270     CONTINUE
11351           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11352   280   CONTINUE
11353
11354 C...Iterate change of initiator momentum to get energy right.
11355         ITER=0
11356   290   ITER=ITER+1
11357         PEEX=-P(N+1,4)-QNEW(4)
11358         PEMV=-P(N+1,3)/P(N+1,4)
11359         DO 300 I=N+2,NCOP
11360           PEEX=PEEX+P(I,4)
11361           PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
11362   300   CONTINUE
11363         IF(ABS(PEMV).LT.1D-10) THEN
11364           MINT(51)=1
11365           MINT(57)=MINT(57)+1
11366           RETURN
11367         ENDIF
11368         PZCH=-PEEX/PEMV
11369         P(N+1,3)=P(N+1,3)+PZCH
11370         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)
11371         DO 310 I=N+2,NCOP
11372           P(I,3)=P(I,3)+V(I,1)*PZCH
11373           P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
11374   310   CONTINUE
11375         IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
11376
11377 C...Modify momenta in event record.
11378         HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
11379      &  ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
11380         IF(ABS(HBE).GT.0.999999D0) THEN
11381           MINT(51)=1
11382           MINT(57)=MINT(57)+1
11383           RETURN
11384         ENDIF
11385         I=MINT(83)+5-LESD
11386         CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
11387         DO 330 I=N+1,NCOP
11388           ICOP=K(I,3)
11389           DO 320 J=1,4
11390             P(ICOP,J)=P(I,J)
11391   320     CONTINUE
11392   330   CONTINUE
11393       ENDIF
11394
11395 C...Check minimum invariant mass of remnant system(s).
11396       PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
11397       PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
11398       PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11399       PMIN(0)=SQRT(PMS(0))
11400       DO 340 JT=1,2
11401         PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
11402         PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
11403         PMIN(JT)=0D0
11404         IF(MINT(44+JT).EQ.1) GOTO 340
11405         MINT(105)=MINT(102+JT)
11406         MINT(109)=MINT(106+JT)
11407         CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
11408         IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
11409         IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
11410         IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
11411         PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
11412      &  P(MINT(83)+JT+2,2)**2)
11413   340 CONTINUE
11414       IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
11415      &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
11416      &PSYS(2,4))) THEN
11417         MINT(51)=1
11418         MINT(57)=MINT(57)+1
11419         RETURN
11420       ENDIF
11421
11422 C...Loop over two remnants; skip if none there.
11423       I=NS
11424       DO 410 JT=1,2
11425         ISN(JT)=0
11426         IF(MINT(44+JT).EQ.1) GOTO 410
11427         IF(JT.EQ.1) IPU=IPU1
11428         IF(JT.EQ.2) IPU=IPU2
11429
11430 C...Store first remnant parton.
11431         I=I+1
11432         IS(JT)=I
11433         ISN(JT)=1
11434         DO 350 J=1,5
11435           K(I,J)=0
11436           P(I,J)=0D0
11437           V(I,J)=0D0
11438   350   CONTINUE
11439         K(I,1)=1
11440         K(I,2)=KFLSP(JT)
11441         K(I,3)=MINT(83)+JT
11442         P(I,5)=PYMASS(K(I,2))
11443
11444 C...First parton colour connections and kinematics.
11445         KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
11446         IF(KCOL.EQ.2) THEN
11447           K(I,1)=3
11448           K(I,4)=MSTU(5)*IPU+IPU
11449           K(I,5)=MSTU(5)*IPU+IPU
11450           K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11451           K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11452         ELSEIF(KCOL.NE.0) THEN
11453           K(I,1)=3
11454           KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
11455           K(I,KFLS+3)=IPU
11456           K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11457         ENDIF
11458         IF(KFLCH(JT).EQ.0) THEN
11459           P(I,1)=-P(MINT(83)+JT+2,1)
11460           P(I,2)=-P(MINT(83)+JT+2,2)
11461           PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11462           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11463           P(I,3)=PSYS(JT,3)
11464           P(I,4)=PSYS(JT,4)
11465
11466 C...When extra remnant parton or hadron: store extra remnant.
11467         ELSE
11468           I=I+1
11469           ISN(JT)=2
11470           DO 360 J=1,5
11471             K(I,J)=0
11472             P(I,J)=0D0
11473             V(I,J)=0D0
11474   360     CONTINUE
11475           K(I,1)=1
11476           K(I,2)=KFLCH(JT)
11477           K(I,3)=MINT(83)+JT
11478           P(I,5)=PYMASS(K(I,2))
11479
11480 C...Find parton colour connections of extra remnant.
11481           KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
11482           IF(KCOL.EQ.2) THEN
11483             K(I,1)=3
11484             K(I,4)=MSTU(5)*IPU+IPU
11485             K(I,5)=MSTU(5)*IPU+IPU
11486             K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
11487             K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
11488           ELSEIF(KCOL.NE.0) THEN
11489             K(I,1)=3
11490             KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
11491             K(I,KFLS+3)=IPU
11492             K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
11493           ENDIF
11494
11495 C...Relative transverse momentum when two remnants.
11496           LOOP=0
11497   370     LOOP=LOOP+1
11498           CALL PYPTDI(1,P(I-1,1),P(I-1,2))
11499           IF(IABS(MINT(10+JT)).LT.20) THEN
11500             P(I-1,1)=0D0
11501             P(I-1,2)=0D0
11502           ENDIF
11503           PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
11504           P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
11505           P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
11506           PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
11507
11508 C...Meson or baryon; photon as meson. For splitup below.
11509           IMB=1
11510           IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
11511
11512 C***Relative distribution for electron into two electrons. Temporary!
11513           IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
11514      &    THEN
11515             CHI(JT)=PYR(0)
11516
11517 C...Relative distribution of electron energy into electron plus parton.
11518           ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
11519             XHRD=VINT(140+JT)
11520             XE=VINT(154+JT)
11521             CHI(JT)=(XE-XHRD)/(1D0-XHRD)
11522
11523 C...Relative distribution of energy for particle into two jets.
11524           ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
11525             CHIK=PARP(92+2*IMB)
11526             IF(MSTP(92).LE.1) THEN
11527               IF(IMB.EQ.1) CHI(JT)=PYR(0)
11528               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11529             ELSEIF(MSTP(92).EQ.2) THEN
11530               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
11531             ELSEIF(MSTP(92).EQ.3) THEN
11532               CUT=2D0*0.3D0/VINT(1)
11533   380         CHI(JT)=PYR(0)**2
11534               IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
11535      &        (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
11536             ELSEIF(MSTP(92).EQ.4) THEN
11537               CUT=2D0*0.3D0/VINT(1)
11538               CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11539   390         CHIR=CUT*CUTR**PYR(0)
11540               CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
11541               IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
11542             ELSE
11543               CUT=2D0*0.3D0/VINT(1)
11544               CUTA=CUT**(1D0-PARP(98))
11545               CUTB=(1D0+CUT)**(1D0-PARP(98))
11546   400         CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11547               IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
11548      &        (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
11549             ENDIF
11550
11551 C...Relative distribution of energy for particle into jet plus particle.
11552           ELSE
11553             IF(MSTP(94).LE.1) THEN
11554               IF(IMB.EQ.1) CHI(JT)=PYR(0)
11555               IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
11556               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11557             ELSEIF(MSTP(94).EQ.2) THEN
11558               CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
11559               IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
11560             ELSEIF(MSTP(94).EQ.3) THEN
11561               CALL PYZDIS(1,0,PMS(JT+4),ZZ)
11562               CHI(JT)=ZZ
11563             ELSE
11564               CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
11565               CHI(JT)=ZZ
11566             ENDIF
11567           ENDIF
11568
11569 C...Construct total transverse mass; reject if too large.
11570           PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
11571           IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
11572             IF(LOOP.LT.10) THEN
11573               GOTO 370
11574             ELSE
11575               MINT(51)=1
11576               MINT(57)=MINT(57)+1
11577               RETURN
11578             ENDIF
11579           ENDIF
11580           PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
11581           VINT(158+JT)=CHI(JT)
11582
11583 C...Subdivide longitudinal momentum according to value selected above.
11584           PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
11585           P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
11586           P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
11587           P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
11588           P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
11589         ENDIF
11590   410 CONTINUE
11591       N=I
11592
11593 C...Check if longitudinal boosts needed - if so pick two systems.
11594       PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
11595      &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
11596       IF(PDEV.LE.1D-6*VINT(1)) RETURN
11597       IF(ISN(1).EQ.0) THEN
11598         IR=0
11599         IL=2
11600       ELSEIF(ISN(2).EQ.0) THEN
11601         IR=1
11602         IL=0
11603       ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
11604         IR=1
11605         IL=2
11606       ELSEIF(VINT(143).GT.0.2D0) THEN
11607         IR=1
11608         IL=0
11609       ELSEIF(VINT(144).GT.0.2D0) THEN
11610         IR=0
11611         IL=2
11612       ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
11613         IR=1
11614         IL=0
11615       ELSE
11616         IR=0
11617         IL=2
11618       ENDIF
11619       IG=3-IR-IL
11620
11621 C...E+-pL wanted for system to be modified.
11622       IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
11623         PPB=VINT(1)
11624         PNB=VINT(1)
11625       ELSE
11626         PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
11627         PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
11628       ENDIF
11629
11630 C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
11631       IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
11632         PMTB=PPB*PNB
11633         PMTR=PMS(IR)
11634         PMTL=PMS(IL)
11635         SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL))
11636         SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11637         RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3))
11638      &  *PNB)
11639         RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3))
11640      &  *PPB)
11641         BER=(RKR**2-1D0)/(RKR**2+1D0)
11642         BEL=-(RKL**2-1D0)/(RKL**2+1D0)
11643         PPB=PPB-(PSYS(0,4)+PSYS(0,3))
11644         PNB=PNB-(PSYS(0,4)-PSYS(0,3))
11645         DO 420 J=1,4
11646           PSYS(0,J)=0D0
11647   420   CONTINUE
11648         DO 450 I=MINT(84)+1,NS
11649           IF(K(I,1).GT.10) GOTO 450
11650           INCL=0
11651           IORIG=I
11652   430     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11653           IORIG=K(IORIG,3)
11654           IF(IORIG.GT.LPIN) GOTO 430
11655           IF(INCL.EQ.0) GOTO 450
11656           DO 440 J=1,4
11657             PSYS(0,J)=PSYS(0,J)+P(I,J)
11658   440     CONTINUE
11659   450   CONTINUE
11660         PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
11661         PPB=PPB+(PSYS(0,4)+PSYS(0,3))
11662         PNB=PNB+(PSYS(0,4)-PSYS(0,3))
11663       ENDIF
11664
11665 C...Construct longitudinal boosts.
11666       DPMTB=PPB*PNB
11667       DPMTR=PMS(IR)
11668       DPMTL=PMS(IL)
11669       DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
11670       IF(DSQLAM.LE.1D-6*DPMTB) THEN
11671         MINT(51)=1
11672         MINT(57)=MINT(57)+1
11673         RETURN
11674       ENDIF
11675       DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
11676       DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
11677      &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
11678       DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
11679      &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
11680       DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
11681       DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
11682
11683 C...Perform longitudinal boosts.
11684       IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
11685         P(IS(1),3)=0D0
11686         P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
11687       ELSEIF(IR.EQ.1) THEN
11688         CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
11689       ELSEIF(IDISXQ.EQ.1) THEN
11690         DO 470 I=I1,NS
11691           INCL=0
11692           IORIG=I
11693   460     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11694           IORIG=K(IORIG,3)
11695           IF(IORIG.GT.LPIN) GOTO 460
11696           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
11697   470   CONTINUE
11698       ELSE
11699         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
11700       ENDIF
11701       IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
11702         P(IS(2),3)=0D0
11703         P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
11704       ELSEIF(IL.EQ.2) THEN
11705         CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
11706       ELSEIF(IDISXQ.EQ.1) THEN
11707         DO 490 I=I1,NS
11708           INCL=0
11709           IORIG=I
11710   480     IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
11711           IORIG=K(IORIG,3)
11712           IF(IORIG.GT.LPIN) GOTO 480
11713           IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
11714   490   CONTINUE
11715       ELSE
11716         CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
11717       ENDIF
11718
11719 C...Final check that energy-momentum conservation worked.
11720       PESUM=0D0
11721       PZSUM=0D0
11722       DO 500 I=MINT(84)+1,N
11723         IF(K(I,1).GT.10) GOTO 500
11724         PESUM=PESUM+P(I,4)
11725         PZSUM=PZSUM+P(I,3)
11726   500 CONTINUE
11727       PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
11728       IF(PDEV.GT.1D-4*VINT(1)) THEN
11729         MINT(51)=1
11730         MINT(57)=MINT(57)+1
11731         RETURN
11732       ENDIF
11733
11734 C...Calculate rotation and boost from overall CM frame to
11735 C...hadronic CM frame in leptoproduction.
11736       MINT(91)=0
11737       IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
11738         MINT(91)=1
11739         LESD=1
11740         IF(MINT(42).EQ.1) LESD=2
11741         LPIN=MINT(83)+3-LESD
11742
11743 C...Sum upp momenta of everything not lepton or photon to define boost.
11744         DO 510 J=1,4
11745           PSUM(J)=0D0
11746   510   CONTINUE
11747         DO 530 I=1,N
11748           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
11749           IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
11750           IF(K(I,2).EQ.22) GOTO 530
11751           DO 520 J=1,4
11752             PSUM(J)=PSUM(J)+P(I,J)
11753   520     CONTINUE
11754   530   CONTINUE
11755         VINT(223)=-PSUM(1)/PSUM(4)
11756         VINT(224)=-PSUM(2)/PSUM(4)
11757         VINT(225)=-PSUM(3)/PSUM(4)
11758
11759 C...Boost incoming hadron to hadronic CM frame to determine rotations.
11760         K(N+1,1)=1
11761         DO 540 J=1,5
11762           P(N+1,J)=P(LPIN,J)
11763           V(N+1,J)=V(LPIN,J)
11764   540   CONTINUE
11765         CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
11766         VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
11767         CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
11768         IF(LESD.EQ.2) THEN
11769           VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
11770         ELSE
11771           VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
11772         ENDIF
11773       ENDIF
11774
11775       RETURN
11776       END
11777
11778 C*********************************************************************
11779
11780 *$ CREATE PYDIFF.FOR
11781 *COPY PYDIFF
11782 C...PYDIFF
11783 C...Handles diffractive and elastic scattering.
11784
11785       SUBROUTINE PYDIFF
11786
11787 C...Double precision and integer declarations.
11788       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
11789       INTEGER PYK,PYCHGE,PYCOMP
11790 C...Commonblocks.
11791       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
11792       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
11793       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
11794       COMMON/PYINT1/MINT(400),VINT(400)
11795       SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
11796
11797 C...Reset K, P and V vectors. Store incoming particles.
11798       DO 110 JT=1,MSTP(126)+10
11799         I=MINT(83)+JT
11800         DO 100 J=1,5
11801           K(I,J)=0
11802           P(I,J)=0D0
11803           V(I,J)=0D0
11804   100   CONTINUE
11805   110 CONTINUE
11806       N=MINT(84)
11807       MINT(3)=0
11808       MINT(21)=0
11809       MINT(22)=0
11810       MINT(23)=0
11811       MINT(24)=0
11812       MINT(4)=4
11813       DO 130 JT=1,2
11814         I=MINT(83)+JT
11815         K(I,1)=21
11816         K(I,2)=MINT(10+JT)
11817         DO 120 J=1,5
11818           P(I,J)=VINT(285+5*JT+J)
11819   120   CONTINUE
11820   130 CONTINUE
11821       MINT(6)=2
11822
11823 C...Subprocess; kinematics.
11824       SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
11825       PZ=SQRT(SQLAM)/(2D0*VINT(1))
11826       DO 200 JT=1,2
11827         I=MINT(83)+JT
11828         PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
11829         KFH=MINT(102+JT)
11830
11831 C...Elastically scattered particle.
11832         IF(MINT(16+JT).LE.0) THEN
11833           N=N+1
11834           K(N,1)=1
11835           K(N,2)=KFH
11836           K(N,3)=I+2
11837           P(N,3)=PZ*(-1)**(JT+1)
11838           P(N,4)=PE
11839           P(N,5)=SQRT(VINT(62+JT))
11840
11841 C...Decay rho from elastic scattering of gamma with sin**2(theta)
11842 C...distribution of decay products (in rho rest frame).
11843           IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
11844             NSAV=N
11845             DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
11846             P(N,3)=0D0
11847             P(N,4)=P(N,5)
11848             CALL PYDECY(NSAV)
11849             IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
11850               PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
11851               CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
11852               THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
11853               CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
11854   140         CTHE=2D0*PYR(0)-1D0
11855               IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
11856               CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
11857             ENDIF
11858             CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
11859           ENDIF
11860
11861 C...Diffracted particle: low-mass system to two particles.
11862         ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
11863           N=N+2
11864           K(N-1,1)=1
11865           K(N,1)=1
11866           K(N-1,3)=I+2
11867           K(N,3)=I+2
11868           PMMAS=SQRT(VINT(62+JT))
11869           NTRY=0
11870   150     NTRY=NTRY+1
11871           IF(NTRY.LT.20) THEN
11872             MINT(105)=MINT(102+JT)
11873             MINT(109)=MINT(106+JT)
11874             CALL PYSPLI(KFH,21,KFL1,KFL2)
11875             CALL PYKFDI(KFL1,0,KFL3,KF1)
11876             IF(KF1.EQ.0) GOTO 150
11877             CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
11878             IF(KF2.EQ.0) GOTO 150
11879           ELSE
11880             KF1=KFH
11881             KF2=111
11882           ENDIF
11883           PM1=PYMASS(KF1)
11884           PM2=PYMASS(KF2)
11885           IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
11886           K(N-1,2)=KF1
11887           K(N,2)=KF2
11888           P(N-1,5)=PM1
11889           P(N,5)=PM2
11890           PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
11891      &    4D0*PM1**2*PM2**2))/(2D0*PMMAS)
11892           P(N-1,3)=PZP
11893           P(N,3)=-PZP
11894           P(N-1,4)=SQRT(PM1**2+PZP**2)
11895           P(N,4)=SQRT(PM2**2+PZP**2)
11896           CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
11897      &    0D0,0D0,0D0)
11898           DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
11899           CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
11900
11901 C...Diffracted particle: valence quark kicked out.
11902         ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
11903      &    PARP(101))) THEN
11904           N=N+2
11905           K(N-1,1)=2
11906           K(N,1)=1
11907           K(N-1,3)=I+2
11908           K(N,3)=I+2
11909           MINT(105)=MINT(102+JT)
11910           MINT(109)=MINT(106+JT)
11911           CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
11912           P(N-1,5)=PYMASS(K(N-1,2))
11913           P(N,5)=PYMASS(K(N,2))
11914           SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
11915      &    4D0*P(N-1,5)**2*P(N,5)**2
11916           P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
11917      &    P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
11918           P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
11919           P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
11920           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11921
11922 C...Diffracted particle: gluon kicked out.
11923         ELSE
11924           N=N+3
11925           K(N-2,1)=2
11926           K(N-1,1)=2
11927           K(N,1)=1
11928           K(N-2,3)=I+2
11929           K(N-1,3)=I+2
11930           K(N,3)=I+2
11931           MINT(105)=MINT(102+JT)
11932           MINT(109)=MINT(106+JT)
11933           CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
11934           K(N-1,2)=21
11935           P(N-2,5)=PYMASS(K(N-2,2))
11936           P(N-1,5)=0D0
11937           P(N,5)=PYMASS(K(N,2))
11938 C...Energy distribution for particle into two jets.
11939   160     IMB=1
11940           IF(MOD(KFH/1000,10).NE.0) IMB=2
11941           CHIK=PARP(92+2*IMB)
11942           IF(MSTP(92).LE.1) THEN
11943             IF(IMB.EQ.1) CHI=PYR(0)
11944             IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
11945           ELSEIF(MSTP(92).EQ.2) THEN
11946             CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
11947           ELSEIF(MSTP(92).EQ.3) THEN
11948             CUT=2D0*0.3D0/VINT(1)
11949   170       CHI=PYR(0)**2
11950             IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
11951      &      PYR(0)) GOTO 170
11952           ELSEIF(MSTP(92).EQ.4) THEN
11953             CUT=2D0*0.3D0/VINT(1)
11954             CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
11955   180       CHIR=CUT*CUTR**PYR(0)
11956             CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
11957             IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
11958           ELSE
11959             CUT=2D0*0.3D0/VINT(1)
11960             CUTA=CUT**(1D0-PARP(98))
11961             CUTB=(1D0+CUT)**(1D0-PARP(98))
11962   190       CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
11963             IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
11964      &      (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
11965           ENDIF
11966           IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
11967      &    VINT(62+JT)) GOTO 160
11968           SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
11969           IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160
11970           PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
11971      &    (2D0*VINT(62+JT))
11972           PEI=SQRT(PZI**2+SQM)
11973           PQQP=(1D0-CHI)*(PEI+PZI)
11974           P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
11975           P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
11976           P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
11977           P(N-1,3)=P(N-1,4)*(-1)**JT
11978           P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
11979           P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
11980         ENDIF
11981
11982 C...Documentation lines.
11983         K(I+2,1)=21
11984         IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
11985         IF(MINT(16+JT).NE.0) K(I+2,2)=10*(KFH/10)
11986         K(I+2,3)=I
11987         P(I+2,3)=PZ*(-1)**(JT+1)
11988         P(I+2,4)=PE
11989         P(I+2,5)=SQRT(VINT(62+JT))
11990   200 CONTINUE
11991
11992 C...Rotate outgoing partons/particles using cos(theta).
11993       IF(VINT(23).LT.0.9D0) THEN
11994         CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
11995       ELSE
11996         CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
11997       ENDIF
11998
11999       RETURN
12000       END
12001
12002 C*********************************************************************
12003
12004 *$ CREATE PYDOCU.FOR
12005 *COPY PYDOCU
12006 C...PYDOCU
12007 C...Handles the documentation of the process in MSTI and PARI,
12008 C...and also computes cross-sections based on accumulated statistics.
12009
12010       SUBROUTINE PYDOCU
12011
12012 C...Double precision and integer declarations.
12013       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12014       INTEGER PYK,PYCHGE,PYCOMP
12015 C...Commonblocks.
12016       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12017       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12018       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12019       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12020       COMMON/PYINT1/MINT(400),VINT(400)
12021       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12022       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
12023       SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
12024      &/PYINT5/
12025
12026 C...Calculate Monte Carlo estimates of cross-sections.
12027       ISUB=MINT(1)
12028       IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
12029       NGEN(0,3)=NGEN(0,3)+1
12030       XSEC(0,3)=0D0
12031       DO 100 I=1,500
12032         IF(I.EQ.96.OR.I.EQ.97) THEN
12033           XSEC(I,3)=0D0
12034         ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
12035      &    I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
12036           XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
12037      &    DBLE(NGEN(96,2)))
12038         ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
12039           XSEC(I,3)=0D0
12040         ELSEIF(NGEN(I,2).EQ.0) THEN
12041           XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
12042      &    DBLE(NGEN(0,2)))
12043         ELSE
12044           XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
12045      &    DBLE(NGEN(I,2)))
12046         ENDIF
12047         XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
12048   100 CONTINUE
12049
12050 C...Rescale to known low-pT cross-section for standard QCD processes.
12051       IF(MSUB(95).EQ.1) THEN
12052         XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
12053      &  XSEC(68,3)+XSEC(95,3)
12054         XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
12055         IF(XSECH.GT.1D-10.AND.XSECW.GT.1D-10) THEN
12056           FAC=XSECW/XSECH
12057           XSEC(11,3)=FAC*XSEC(11,3)
12058           XSEC(12,3)=FAC*XSEC(12,3)
12059           XSEC(13,3)=FAC*XSEC(13,3)
12060           XSEC(28,3)=FAC*XSEC(28,3)
12061           XSEC(53,3)=FAC*XSEC(53,3)
12062           XSEC(68,3)=FAC*XSEC(68,3)
12063           XSEC(95,3)=FAC*XSEC(95,3)
12064           XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
12065         ENDIF
12066       ENDIF
12067
12068 C...Save information for gamma-p and gamma-gamma.
12069       IF(MINT(121).GT.1) THEN
12070         IGA=MINT(122)
12071         CALL PYSAVE(2,IGA)
12072         CALL PYSAVE(5,0)
12073       ENDIF
12074
12075 C...Reset information on hard interaction.
12076       DO 110 J=1,200
12077         MSTI(J)=0
12078         PARI(J)=0D0
12079   110 CONTINUE
12080
12081 C...Copy integer valued information from MINT into MSTI.
12082       DO 120 J=1,32
12083         MSTI(J)=MINT(J)
12084   120 CONTINUE
12085       IF(MINT(121).GT.1) MSTI(9)=MINT(122)
12086
12087 C...Store cross-section variables in PARI.
12088       PARI(1)=XSEC(0,3)
12089       PARI(2)=XSEC(0,3)/MINT(5)
12090       PARI(9)=VINT(99)
12091       PARI(10)=VINT(100)
12092       VINT(98)=VINT(98)+VINT(100)
12093       IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
12094
12095 C...Store kinematics variables in PARI.
12096       PARI(11)=VINT(1)
12097       PARI(12)=VINT(2)
12098       IF(ISUB.NE.95) THEN
12099         DO 130 J=13,26
12100           PARI(J)=VINT(30+J)
12101   130   CONTINUE
12102         PARI(31)=VINT(141)
12103         PARI(32)=VINT(142)
12104         PARI(33)=VINT(41)
12105         PARI(34)=VINT(42)
12106         PARI(35)=PARI(33)-PARI(34)
12107         PARI(36)=VINT(21)
12108         PARI(37)=VINT(22)
12109         PARI(38)=VINT(26)
12110         PARI(39)=VINT(157)
12111         PARI(40)=VINT(158)
12112         PARI(41)=VINT(23)
12113         PARI(42)=2D0*VINT(47)/VINT(1)
12114       ENDIF
12115
12116 C...Store information on scattered partons in PARI.
12117       IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
12118         DO 140 IS=7,8
12119           I=MINT(IS)
12120           PARI(36+IS)=P(I,3)/VINT(1)
12121           PARI(38+IS)=P(I,4)/VINT(1)
12122           PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
12123           PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12124      &    SQRT(PR),1D20)),P(I,3))
12125           PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
12126           PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
12127      &    SQRT(PR),1D20)),P(I,3))
12128           PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
12129           PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
12130           PARI(48+IS)=PYANGL(P(I,1),P(I,2))
12131   140   CONTINUE
12132       ENDIF
12133
12134 C...Store sum up transverse and longitudinal momenta.
12135       PARI(65)=2D0*PARI(17)
12136       IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
12137         DO 150 I=MSTP(126)+1,N
12138           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
12139           PT=SQRT(P(I,1)**2+P(I,2)**2)
12140           PARI(69)=PARI(69)+PT
12141           IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
12142           IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
12143   150   CONTINUE
12144         PARI(67)=PARI(68)
12145         PARI(71)=VINT(151)
12146         PARI(72)=VINT(152)
12147         PARI(73)=VINT(151)
12148         PARI(74)=VINT(152)
12149       ELSE
12150         PARI(66)=PARI(65)
12151         PARI(69)=PARI(65)
12152       ENDIF
12153
12154 C...Store various other pieces of information into PARI.
12155       PARI(61)=VINT(148)
12156       PARI(75)=VINT(155)
12157       PARI(76)=VINT(156)
12158       PARI(77)=VINT(159)
12159       PARI(78)=VINT(160)
12160       PARI(81)=VINT(138)
12161
12162 C...Set information for PYTABU.
12163       IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
12164         MSTU(161)=MINT(21)
12165         MSTU(162)=0
12166       ELSEIF(ISET(ISUB).EQ.5) THEN
12167         MSTU(161)=MINT(23)
12168         MSTU(162)=0
12169       ELSE
12170         MSTU(161)=MINT(21)
12171         MSTU(162)=MINT(22)
12172       ENDIF
12173
12174       RETURN
12175       END
12176
12177 C*********************************************************************
12178
12179 *$ CREATE PYFRAM.FOR
12180 *COPY PYFRAM
12181 C...PYFRAM
12182 C...Performs transformations between different coordinate frames.
12183
12184       SUBROUTINE PYFRAM(IFRAME)
12185
12186 C...Double precision and integer declarations.
12187       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12188       INTEGER PYK,PYCHGE,PYCOMP
12189 C...Commonblocks.
12190       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12191       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12192       COMMON/PYINT1/MINT(400),VINT(400)
12193       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
12194
12195 C...Check that transformation can and should be done.
12196       IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
12197      &MINT(91).EQ.1)) THEN
12198         IF(IFRAME.EQ.MINT(6)) RETURN
12199       ELSE
12200         WRITE(MSTU(11),5000) IFRAME,MINT(6)
12201         RETURN
12202       ENDIF
12203
12204       IF(MINT(6).EQ.1) THEN
12205 C...Transform from fixed target or user specified frame to
12206 C...overall CM frame.
12207         CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
12208         CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
12209         CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
12210       ELSEIF(MINT(6).EQ.3) THEN
12211 C...Transform from hadronic CM frame in DIS to overall CM frame.
12212         CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
12213      &  -VINT(225))
12214       ENDIF
12215
12216       IF(IFRAME.EQ.1) THEN
12217 C...Transform from overall CM frame to fixed target or user specified
12218 C...frame.
12219         CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
12220       ELSEIF(IFRAME.EQ.3) THEN
12221 C...Transform from overall CM frame to hadronic CM frame in DIS.
12222         CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
12223         CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
12224         CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
12225       ENDIF
12226
12227 C...Set information about new frame.
12228       MINT(6)=IFRAME
12229       MSTI(6)=IFRAME
12230
12231  5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
12232      &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
12233      &1X,I5)
12234
12235       RETURN
12236       END
12237
12238 C*********************************************************************
12239
12240 *$ CREATE PYWIDT.FOR
12241 *COPY PYWIDT
12242 C...PYWIDT
12243 C...Calculates full and partial widths of resonances.
12244
12245       SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
12246
12247 C...Double precision and integer declarations.
12248       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12249       INTEGER PYK,PYCHGE,PYCOMP
12250 C...Parameter statement to help give large particle numbers.
12251       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
12252 C...Commonblocks.
12253       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12254       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12255       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
12256       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12257       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12258       COMMON/PYINT1/MINT(400),VINT(400)
12259       COMMON/PYINT4/MWID(500),WIDS(500,5)
12260       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
12261       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
12262      &SFMIX(16,4)
12263       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
12264      &/PYINT4/,/PYMSSM/,/PYSSMT/
12265 C...Local arrays and saved variables.
12266       DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2),
12267      &WID2SV(3,2)
12268       SAVE MOFSV,WIDWSV,WID2SV
12269       DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
12270
12271 C...Compressed code and sign; mass.
12272       KFLA=IABS(KFLR)
12273       KFLS=ISIGN(1,KFLR)
12274       KC=PYCOMP(KFLA)
12275       SHR=SQRT(SH)
12276       PMR=PMAS(KC,1)
12277
12278 C...Reset width information.
12279       DO 110 I=0,200
12280         WDTP(I)=0D0
12281         DO 100 J=0,5
12282           WDTE(I,J)=0D0
12283   100   CONTINUE
12284   110 CONTINUE
12285
12286 C...Not to be treated as a resonance: return.
12287       IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
12288      &KFLA.NE.22) THEN
12289         WDTP(0)=1D0
12290         WDTE(0,0)=1D0
12291         MINT(61)=0
12292         MINT(62)=0
12293         MINT(63)=0
12294         RETURN
12295
12296 C...Treatment as a resonance based on tabulated branching ratios.
12297       ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
12298 C...Loop over possible decay channels; skip irrelevant ones.
12299         DO 120 I=1,MDCY(KC,3)
12300           IDC=I+MDCY(KC,2)-1
12301           IF(MDME(IDC,1).LT.0) GOTO 120
12302
12303 C...Read out decay products and nominal masses.
12304           KFD1=KFDP(IDC,1)
12305           KFC1=PYCOMP(KFD1)
12306           IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
12307           PM1=PMAS(KFC1,1)
12308           KFD2=KFDP(IDC,2)
12309           KFC2=PYCOMP(KFD2)
12310           IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
12311           PM2=PMAS(KFC2,1)
12312           KFD3=KFDP(IDC,3)
12313           PM3=0D0
12314           IF(KFD3.NE.0) THEN
12315             KFC3=PYCOMP(KFD3)
12316             IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
12317             PM3=PMAS(KFC3,1)
12318           ENDIF
12319
12320 C...Naive partial width and alternative threshold factors.
12321           WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
12322           IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
12323      &    PM1+PM2+PM3.GE.SHR) THEN
12324              WDTP(I)=0D0
12325           ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
12326             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
12327      &      4D0*PM1**2*PM2**2))/SH
12328           ELSEIF(MDME(IDC,2).EQ.52) THEN
12329             PMA=MAX(PM1,PM2,PM3)
12330             PMC=MIN(PM1,PM2,PM3)
12331             PMB=PM1+PM2+PM3-PMA-PMC
12332             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
12333             PMAN=PMA**2/SH
12334             PMBN=PMB**2/SH
12335             PMCN=PMC**2/SH
12336             PMBCN=PMBC**2/SH
12337             WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
12338      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12339      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12340      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
12341      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12342      &      ((1D0-PMBCN)*PMBCN*SH)
12343           ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
12344             WDTP(I)=WDTP(I)*SQRT(
12345      &      MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
12346      &      MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
12347           ELSEIF(MDME(IDC,2).EQ.53) THEN
12348             PMA=MAX(PM1,PM2,PM3)
12349             PMC=MIN(PM1,PM2,PM3)
12350             PMB=PM1+PM2+PM3-PMA-PMC
12351             PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
12352             PMAN=PMA**2/SH
12353             PMBN=PMB**2/SH
12354             PMCN=PMC**2/SH
12355             PMBCN=PMBC**2/SH
12356             FACACT=SQRT(MAX(0D0,
12357      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12358      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12359      &      ((SHR-PMA)**2-(PMB+PMC)**2)*
12360      &      (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
12361      &      ((1D0-PMBCN)*PMBCN*SH)
12362             PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
12363             PMAN=PMA**2/PMR**2
12364             PMBN=PMB**2/PMR**2
12365             PMCN=PMC**2/PMR**2
12366             PMBCN=PMBC**2/PMR**2
12367             FACNOM=SQRT(MAX(0D0,
12368      &      ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
12369      &      ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
12370      &      ((PMR-PMA)**2-(PMB+PMC)**2)*
12371      &      (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
12372      &      ((1D0-PMBCN)*PMBCN*PMR**2)
12373             WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
12374           ENDIF
12375           WDTP(0)=WDTP(0)+WDTP(I)
12376
12377 C...Calculate secondary width (at most two identical/opposite).
12378           IF(MDME(IDC,1).GT.0) THEN
12379             IF(KFD2.EQ.KFD1) THEN
12380               IF(KCHG(KFC1,3).EQ.0) THEN
12381                 WID2=WIDS(KFC1,1)
12382               ELSEIF(KFD1.GT.0) THEN
12383                 WID2=WIDS(KFC1,4)
12384               ELSE
12385                 WID2=WIDS(KFC1,5)
12386               ENDIF
12387               IF(KFD3.GT.0) THEN
12388                 WID2=WID2*WIDS(KFC3,2)
12389               ELSEIF(KFD3.LT.0) THEN
12390                 WID2=WID2*WIDS(KFC3,3)
12391               ENDIF
12392             ELSEIF(KFD2.EQ.-KFD1) THEN
12393               WID2=WIDS(KFC1,1)
12394               IF(KFD3.GT.0) THEN
12395                 WID2=WID2*WIDS(KFC3,2)
12396               ELSEIF(KFD3.LT.0) THEN
12397                 WID2=WID2*WIDS(KFC3,3)
12398               ENDIF
12399             ELSEIF(KFD3.EQ.KFD1) THEN
12400               IF(KCHG(KFC1,3).EQ.0) THEN
12401                 WID2=WIDS(KFC1,1)
12402               ELSEIF(KFD1.GT.0) THEN
12403                 WID2=WIDS(KFC1,4)
12404               ELSE
12405                 WID2=WIDS(KFC1,5)
12406               ENDIF
12407               IF(KFD2.GT.0) THEN
12408                 WID2=WID2*WIDS(KFC2,2)
12409               ELSEIF(KFD2.LT.0) THEN
12410                 WID2=WID2*WIDS(KFC2,3)
12411               ENDIF
12412             ELSEIF(KFD3.EQ.-KFD1) THEN
12413               WID2=WIDS(KFC1,1)
12414               IF(KFD2.GT.0) THEN
12415                 WID2=WID2*WIDS(KFC2,2)
12416               ELSEIF(KFD2.LT.0) THEN
12417                 WID2=WID2*WIDS(KFC2,3)
12418               ENDIF
12419             ELSEIF(KFD3.EQ.KFD2) THEN
12420               IF(KCHG(KFC2,3).EQ.0) THEN
12421                 WID2=WIDS(KFC2,1)
12422               ELSEIF(KFD2.GT.0) THEN
12423                 WID2=WIDS(KFC2,4)
12424               ELSE
12425                 WID2=WIDS(KFC2,5)
12426               ENDIF
12427               IF(KFD1.GT.0) THEN
12428                 WID2=WID2*WIDS(KFC1,2)
12429               ELSEIF(KFD1.LT.0) THEN
12430                 WID2=WID2*WIDS(KFC1,3)
12431               ENDIF
12432             ELSEIF(KFD3.EQ.-KFD2) THEN
12433               WID2=WIDS(KFC2,1)
12434               IF(KFD1.GT.0) THEN
12435                 WID2=WID2*WIDS(KFC1,2)
12436               ELSEIF(KFD1.LT.0) THEN
12437                 WID2=WID2*WIDS(KFC1,3)
12438               ENDIF
12439             ELSE
12440               IF(KFD1.GT.0) THEN
12441                 WID2=WIDS(KFC1,2)
12442               ELSE
12443                 WID2=WIDS(KFC1,3)
12444               ENDIF
12445               IF(KFD2.GT.0) THEN
12446                 WID2=WID2*WIDS(KFC2,2)
12447               ELSE
12448                 WID2=WID2*WIDS(KFC2,3)
12449               ENDIF
12450               IF(KFD3.GT.0) THEN
12451                 WID2=WID2*WIDS(KFC3,2)
12452               ELSEIF(KFD3.LT.0) THEN
12453                 WID2=WID2*WIDS(KFC3,3)
12454               ENDIF
12455             ENDIF
12456
12457 C...Store effective widths according to case.
12458             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12459             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12460             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12461             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12462           ENDIF
12463   120   CONTINUE
12464 C...Return.
12465         MINT(61)=0
12466         MINT(62)=0
12467         MINT(63)=0
12468         RETURN
12469       ENDIF
12470
12471 C...Here begins detailed dynamical calculation of resonance widths.
12472 C...Shared treatment of Higgs states.
12473       KFHIGG=25
12474       IHIGG=1
12475       IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12476         KFHIGG=KFLA
12477         IHIGG=KFLA-33
12478       ENDIF
12479
12480 C...Common electroweak and strong constants.
12481       XW=PARU(102)
12482       XWV=XW
12483       IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
12484       XW1=1D0-XW
12485       AEM=PYALEM(SH)
12486       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
12487       AS=PYALPS(SH)
12488       RADC=1D0+AS/PARU(1)
12489
12490       IF(KFLA.EQ.6) THEN
12491 C...t quark.
12492         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12493         RADCT=1D0-2.5D0*AS/PARU(1)
12494         DO 130 I=1,MDCY(KC,3)
12495           IDC=I+MDCY(KC,2)-1
12496           IF(MDME(IDC,1).LT.0) GOTO 130
12497           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12498           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12499           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
12500           IF(I.GE.4.AND.I.LE.7) THEN
12501 C...t -> W + q; including approximate QCD correction factor.
12502             WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
12503      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12504      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12505             IF(KFLR.GT.0) THEN
12506               WID2=WIDS(24,2)
12507               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12508             ELSE
12509               WID2=WIDS(24,3)
12510               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12511             ENDIF
12512           ELSEIF(I.EQ.9) THEN
12513 C...t -> H + b.
12514             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12515      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12516             WID2=WIDS(37,2)
12517             IF(KFLR.LT.0) WID2=WIDS(37,3)
12518 CMRENNA++
12519           ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
12520 C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
12521             BETA=ATAN(RMSS(5))
12522             SINB=SIN(BETA)
12523             TANW=SQRT(PARU(102)/(1D0-PARU(102)))
12524             ET=KCHG(6,1)/3D0
12525             T3L=SIGN(0.5D0,ET)
12526             KFC1=PYCOMP(KFDP(IDC,1))
12527             KFC2=PYCOMP(KFDP(IDC,2))
12528             PMNCHI=PMAS(KFC1,1)
12529             PMSTOP=PMAS(KFC2,1)
12530             IF(SHR.GT.PMNCHI+PMSTOP) THEN
12531               IZ=I-9
12532               AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB)
12533               AR=-ET*ZMIX(IZ,1)*TANW
12534               BL=T3L*(ZMIX(IZ,2)-ZMIX(IZ,1)*TANW)-AR
12535               BR=AL
12536               FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
12537               FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
12538               PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
12539      &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
12540               WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*((FL**2+FR**2)*
12541      &        (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH
12542               IF(KFLR.GT.0) THEN
12543                 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
12544               ELSE
12545                 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
12546               ENDIF
12547             ENDIF
12548 CMRENNA--
12549           ENDIF
12550           WDTP(0)=WDTP(0)+WDTP(I)
12551           IF(MDME(IDC,1).GT.0) THEN
12552             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12553             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12554             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12555             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12556           ENDIF
12557   130   CONTINUE
12558
12559       ELSEIF(KFLA.EQ.7) THEN
12560 C...b' quark.
12561         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12562         DO 140 I=1,MDCY(KC,3)
12563           IDC=I+MDCY(KC,2)-1
12564           IF(MDME(IDC,1).LT.0) GOTO 140
12565           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12566           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12567           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
12568           IF(I.GE.4.AND.I.LE.7) THEN
12569 C...b' -> W + q.
12570             WDTP(I)=FAC*VCKM(I-3,4)*
12571      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12572      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12573             IF(KFLR.GT.0) THEN
12574               WID2=WIDS(24,3)
12575               IF(I.EQ.6) WID2=WID2*WIDS(6,2)
12576               IF(I.EQ.7) WID2=WID2*WIDS(8,2)
12577             ELSE
12578               WID2=WIDS(24,2)
12579               IF(I.EQ.6) WID2=WID2*WIDS(6,3)
12580               IF(I.EQ.7) WID2=WID2*WIDS(8,3)
12581             ENDIF
12582             WID2=WIDS(24,3)
12583             IF(KFLR.LT.0) WID2=WIDS(24,2)
12584           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12585 C...b' -> H + q.
12586             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12587      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12588             IF(KFLR.GT.0) THEN
12589               WID2=WIDS(37,3)
12590               IF(I.EQ.10) WID2=WID2*WIDS(6,2)
12591             ELSE
12592               WID2=WIDS(37,2)
12593               IF(I.EQ.10) WID2=WID2*WIDS(6,3)
12594             ENDIF
12595           ENDIF
12596           WDTP(0)=WDTP(0)+WDTP(I)
12597           IF(MDME(IDC,1).GT.0) THEN
12598             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12599             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12600             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12601             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12602           ENDIF
12603   140   CONTINUE
12604
12605       ELSEIF(KFLA.EQ.8) THEN
12606 C...t' quark.
12607         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12608         DO 150 I=1,MDCY(KC,3)
12609           IDC=I+MDCY(KC,2)-1
12610           IF(MDME(IDC,1).LT.0) GOTO 150
12611           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12612           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12613           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
12614           IF(I.GE.4.AND.I.LE.7) THEN
12615 C...t' -> W + q.
12616             WDTP(I)=FAC*VCKM(4,I-3)*
12617      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12618      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12619             IF(KFLR.GT.0) THEN
12620               WID2=WIDS(24,2)
12621               IF(I.EQ.7) WID2=WID2*WIDS(7,2)
12622             ELSE
12623               WID2=WIDS(24,3)
12624               IF(I.EQ.7) WID2=WID2*WIDS(7,3)
12625             ENDIF
12626           ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
12627 C...t' -> H + q.
12628             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12629      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12630             IF(KFLR.GT.0) THEN
12631               WID2=WIDS(37,2)
12632               IF(I.EQ.10) WID2=WID2*WIDS(7,2)
12633             ELSE
12634               WID2=WIDS(37,3)
12635               IF(I.EQ.10) WID2=WID2*WIDS(7,3)
12636             ENDIF
12637           ENDIF
12638           WDTP(0)=WDTP(0)+WDTP(I)
12639           IF(MDME(IDC,1).GT.0) THEN
12640             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12641             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12642             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12643             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12644           ENDIF
12645   150   CONTINUE
12646
12647       ELSEIF(KFLA.EQ.17) THEN
12648 C...tau' lepton.
12649         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12650         DO 160 I=1,MDCY(KC,3)
12651           IDC=I+MDCY(KC,2)-1
12652           IF(MDME(IDC,1).LT.0) GOTO 160
12653           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12654           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12655           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
12656           IF(I.EQ.3) THEN
12657 C...tau' -> W + nu'_tau.
12658             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12659      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12660             IF(KFLR.GT.0) THEN
12661               WID2=WIDS(24,3)
12662               WID2=WID2*WIDS(18,2)
12663             ELSE
12664               WID2=WIDS(24,2)
12665               WID2=WID2*WIDS(18,3)
12666             ENDIF
12667           ELSEIF(I.EQ.5) THEN
12668 C...tau' -> H + nu'_tau.
12669             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12670      &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
12671             IF(KFLR.GT.0) THEN
12672               WID2=WIDS(37,3)
12673               WID2=WID2*WIDS(18,2)
12674             ELSE
12675               WID2=WIDS(37,2)
12676               WID2=WID2*WIDS(18,3)
12677             ENDIF
12678           ENDIF
12679           WDTP(0)=WDTP(0)+WDTP(I)
12680           IF(MDME(IDC,1).GT.0) THEN
12681             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12682             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12683             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12684             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12685           ENDIF
12686   160   CONTINUE
12687
12688       ELSEIF(KFLA.EQ.18) THEN
12689 C...nu'_tau neutrino.
12690         FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
12691         DO 170 I=1,MDCY(KC,3)
12692           IDC=I+MDCY(KC,2)-1
12693           IF(MDME(IDC,1).LT.0) GOTO 170
12694           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
12695           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
12696           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
12697           IF(I.EQ.2) THEN
12698 C...nu'_tau -> W + tau'.
12699             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12700      &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
12701             IF(KFLR.GT.0) THEN
12702               WID2=WIDS(24,2)
12703               WID2=WID2*WIDS(17,2)
12704             ELSE
12705               WID2=WIDS(24,3)
12706               WID2=WID2*WIDS(17,3)
12707             ENDIF
12708           ELSEIF(I.EQ.3) THEN
12709 C...nu'_tau -> H + tau'.
12710             WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
12711      &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
12712             IF(KFLR.GT.0) THEN
12713               WID2=WIDS(37,2)
12714               WID2=WID2*WIDS(17,2)
12715             ELSE
12716               WID2=WIDS(37,3)
12717               WID2=WID2*WIDS(17,3)
12718             ENDIF
12719           ENDIF
12720           WDTP(0)=WDTP(0)+WDTP(I)
12721           IF(MDME(IDC,1).GT.0) THEN
12722             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12723             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12724             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12725             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12726           ENDIF
12727   170   CONTINUE
12728
12729       ELSEIF(KFLA.EQ.21) THEN
12730 C...QCD:
12731 C***Note that widths are not given in dimensional quantities here.
12732         DO 180 I=1,MDCY(KC,3)
12733           IDC=I+MDCY(KC,2)-1
12734           IF(MDME(IDC,1).LT.0) GOTO 180
12735           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12736           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12737           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
12738           WID2=1D0
12739           IF(I.LE.8) THEN
12740 C...QCD -> q + qbar
12741             WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12742             IF(I.EQ.6) WID2=WIDS(6,1)
12743             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12744           ENDIF
12745           WDTP(0)=WDTP(0)+WDTP(I)
12746           IF(MDME(IDC,1).GT.0) THEN
12747             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12748             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12749             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12750             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12751           ENDIF
12752   180   CONTINUE
12753
12754       ELSEIF(KFLA.EQ.22) THEN
12755 C...QED photon.
12756 C***Note that widths are not given in dimensional quantities here.
12757         DO 190 I=1,MDCY(KC,3)
12758           IDC=I+MDCY(KC,2)-1
12759           IF(MDME(IDC,1).LT.0) GOTO 190
12760           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12761           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12762           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
12763           WID2=1D0
12764           IF(I.LE.8) THEN
12765 C...QED -> q + qbar.
12766             EF=KCHG(I,1)/3D0
12767             FCOF=3D0*RADC
12768             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12769             WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12770             IF(I.EQ.6) WID2=WIDS(6,1)
12771             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12772           ELSEIF(I.LE.12) THEN
12773 C...QED -> l+ + l-.
12774             EF=KCHG(9+2*(I-8),1)/3D0
12775             WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12776             IF(I.EQ.12) WID2=WIDS(17,1)
12777           ENDIF
12778           WDTP(0)=WDTP(0)+WDTP(I)
12779           IF(MDME(IDC,1).GT.0) THEN
12780             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12781             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12782             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12783             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12784           ENDIF
12785   190   CONTINUE
12786
12787       ELSEIF(KFLA.EQ.23) THEN
12788 C...Z0:
12789         ICASE=1
12790         XWC=1D0/(16D0*XW*XW1)
12791         FAC=(AEM*XWC/3D0)*SHR
12792   200   CONTINUE
12793         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
12794           VINT(111)=0D0
12795           VINT(112)=0D0
12796           VINT(114)=0D0
12797         ENDIF
12798         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12799           KFI=IABS(MINT(15))
12800           IF(KFI.GT.20) KFI=IABS(MINT(16))
12801           EI=KCHG(KFI,1)/3D0
12802           AI=SIGN(1D0,EI)
12803           VI=AI-4D0*EI*XWV
12804           SQMZ=PMAS(23,1)**2
12805           HZ=SHR*WDTP(0)
12806           IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
12807           IF(MSTP(43).EQ.3) VINT(112)=
12808      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
12809           IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12810      &    XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
12811         ENDIF
12812         DO 210 I=1,MDCY(KC,3)
12813           IDC=I+MDCY(KC,2)-1
12814           IF(MDME(IDC,1).LT.0) GOTO 210
12815           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12816           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12817           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 210
12818           WID2=1D0
12819           IF(I.LE.8) THEN
12820 C...Z0 -> q + qbar
12821             EF=KCHG(I,1)/3D0
12822             AF=SIGN(1D0,EF+0.1D0)
12823             VF=AF-4D0*EF*XWV
12824             FCOF=3D0*RADC
12825             IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
12826             IF(I.EQ.6) WID2=WIDS(6,1)
12827             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12828           ELSEIF(I.LE.16) THEN
12829 C...Z0 -> l+ + l-, nu + nubar
12830             EF=KCHG(I+2,1)/3D0
12831             AF=SIGN(1D0,EF+0.1D0)
12832             VF=AF-4D0*EF*XWV
12833             FCOF=1D0
12834             IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
12835           ENDIF
12836           BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
12837           IF(ICASE.EQ.1) THEN
12838             WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
12839      &      BE34
12840           ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
12841             WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
12842      &      EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
12843      &      (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
12844           ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12845             FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
12846             FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
12847             FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
12848           ENDIF
12849           IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
12850           IF(MDME(IDC,1).GT.0) THEN
12851             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
12852      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
12853               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12854               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
12855      &        WDTE(I,MDME(IDC,1))
12856               WDTE(I,0)=WDTE(I,MDME(IDC,1))
12857               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12858             ENDIF
12859             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
12860               IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
12861      &        VINT(111)+FGGF*WID2
12862               IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
12863               IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
12864      &        VINT(114)+FZZF*WID2
12865             ENDIF
12866           ENDIF
12867   210   CONTINUE
12868         IF(MINT(61).GE.1) ICASE=3-ICASE
12869         IF(ICASE.EQ.2) GOTO 200
12870
12871       ELSEIF(KFLA.EQ.24) THEN
12872 C...W+/-:
12873         FAC=(AEM/(24D0*XW))*SHR
12874         DO 220 I=1,MDCY(KC,3)
12875           IDC=I+MDCY(KC,2)-1
12876           IF(MDME(IDC,1).LT.0) GOTO 220
12877           RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
12878           RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
12879           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
12880           WID2=1D0
12881           IF(I.LE.16) THEN
12882 C...W+/- -> q + qbar'
12883             FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
12884             IF(KFLR.GT.0) THEN
12885               IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
12886               IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
12887               IF(I.GE.13) WID2=WID2*WIDS(7,3)
12888             ELSE
12889               IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
12890               IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
12891               IF(I.GE.13) WID2=WID2*WIDS(7,2)
12892             ENDIF
12893           ELSEIF(I.LE.20) THEN
12894 C...W+/- -> l+/- + nu
12895             FCOF=1D0
12896             IF(KFLR.GT.0) THEN
12897               IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
12898             ELSE
12899               IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
12900             ENDIF
12901           ENDIF
12902           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
12903      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
12904           WDTP(0)=WDTP(0)+WDTP(I)
12905           IF(MDME(IDC,1).GT.0) THEN
12906             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
12907             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
12908             WDTE(I,0)=WDTE(I,MDME(IDC,1))
12909             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
12910           ENDIF
12911   220   CONTINUE
12912
12913       ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
12914 C...h0 (or H0, or A0):
12915         IF(MSTP(49).EQ.0) THEN
12916           FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
12917         ELSE
12918           FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR
12919         ENDIF
12920         DO 260 I=1,MDCY(KFHIGG,3)
12921           IDC=I+MDCY(KFHIGG,2)-1
12922           IF(MDME(IDC,1).LT.0) GOTO 260
12923           KFC1=PYCOMP(KFDP(IDC,1))
12924           KFC2=PYCOMP(KFDP(IDC,2))
12925           RM1=PMAS(KFC1,1)**2/SH
12926           RM2=PMAS(KFC2,1)**2/SH
12927           IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
12928      &    GOTO 260
12929           WID2=1D0
12930
12931           IF(I.LE.8) THEN
12932 C...h0 -> q + qbar
12933             WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,
12934      &      1D0-4D0*RM1))*RADC
12935             IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)*
12936      &      (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
12937      &      LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
12938             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12939               IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
12940               IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
12941             ENDIF
12942             IF(I.EQ.6) WID2=WIDS(6,1)
12943             IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
12944
12945           ELSEIF(I.LE.12) THEN
12946 C...h0 -> l+ + l-
12947             WDTP(I)=FAC*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
12948             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
12949      &      PARU(153+10*IHIGG)**2
12950             IF(I.EQ.12) WID2=WIDS(17,1)
12951
12952           ELSEIF(I.EQ.13) THEN
12953 C...h0 -> g + g; quark loop contribution only
12954             ETARE=0D0
12955             ETAIM=0D0
12956             DO 230 J=1,2*MSTP(1)
12957               EPS=(2D0*PMAS(J,1))**2/SH
12958 C...Loop integral; function of eps=4m^2/shat; different for A0.
12959               IF(EPS.LE.1D0) THEN
12960                 IF(EPS.GT.1.D-4) THEN
12961                   ROOT=SQRT(1D0-EPS)
12962                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
12963                 ELSE
12964                   RLN=LOG(4D0/EPS-2D0)
12965                 ENDIF
12966                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
12967                 PHIIM=0.5D0*PARU(1)*RLN
12968               ELSE
12969                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
12970                 PHIIM=0D0
12971               ENDIF
12972               IF(IHIGG.LE.2) THEN
12973                 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
12974                 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
12975               ELSE
12976                 ETAREJ=-0.5D0*EPS*PHIRE
12977                 ETAIMJ=-0.5D0*EPS*PHIIM
12978               ENDIF
12979 C...Couplings (=1 for standard model Higgs).
12980               IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
12981                 IF(MOD(J,2).EQ.1) THEN
12982                   ETAREJ=ETAREJ*PARU(151+10*IHIGG)
12983                   ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
12984                 ELSE
12985                   ETAREJ=ETAREJ*PARU(152+10*IHIGG)
12986                   ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
12987                 ENDIF
12988               ENDIF
12989               ETARE=ETARE+ETAREJ
12990               ETAIM=ETAIM+ETAIMJ
12991   230       CONTINUE
12992             ETA2=ETARE**2+ETAIM**2
12993             WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
12994
12995           ELSEIF(I.EQ.14) THEN
12996 C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
12997             ETARE=0D0
12998             ETAIM=0D0
12999             JMAX=3*MSTP(1)+1
13000             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13001             DO 240 J=1,JMAX
13002               IF(J.LE.2*MSTP(1)) THEN
13003                 EJ=KCHG(J,1)/3D0
13004                 EPS=(2D0*PMAS(J,1))**2/SH
13005               ELSEIF(J.LE.3*MSTP(1)) THEN
13006                 JL=2*(J-2*MSTP(1))-1
13007                 EJ=KCHG(10+JL,1)/3D0
13008                 EPS=(2D0*PMAS(10+JL,1))**2/SH
13009               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13010                 EPS=(2D0*PMAS(24,1))**2/SH
13011               ELSE
13012                 EPS=(2D0*PMAS(37,1))**2/SH
13013               ENDIF
13014 C...Loop integral; function of eps=4m^2/shat.
13015               IF(EPS.LE.1D0) THEN
13016                 IF(EPS.GT.1.D-4) THEN
13017                   ROOT=SQRT(1D0-EPS)
13018                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13019                 ELSE
13020                   RLN=LOG(4D0/EPS-2D0)
13021                 ENDIF
13022                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13023                 PHIIM=0.5D0*PARU(1)*RLN
13024               ELSE
13025                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13026                 PHIIM=0D0
13027               ENDIF
13028               IF(J.LE.3*MSTP(1)) THEN
13029 C...Fermion loops: loop integral different for A0; charges.
13030                 IF(IHIGG.LE.2) THEN
13031                   PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
13032                   PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
13033                 ELSE
13034                   PHIPRE=-0.5D0*EPS*PHIRE
13035                   PHIPIM=-0.5D0*EPS*PHIIM
13036                 ENDIF
13037                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13038                   EJC=3D0*EJ**2
13039                   EJH=PARU(151+10*IHIGG)
13040                 ELSEIF(J.LE.2*MSTP(1)) THEN
13041                   EJC=3D0*EJ**2
13042                   EJH=PARU(152+10*IHIGG)
13043                 ELSE
13044                   EJC=EJ**2
13045                   EJH=PARU(153+10*IHIGG)
13046                 ENDIF
13047                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13048                 ETAREJ=EJC*EJH*PHIPRE
13049                 ETAIMJ=EJC*EJH*PHIPIM
13050               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13051 C...W loops: loop integral and charges.
13052                 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
13053                 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
13054                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13055                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13056                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13057                 ENDIF
13058               ELSE
13059 C...Charged H loops: loop integral and charges.
13060                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
13061      &          PARU(158+10*IHIGG+2*(IHIGG/3))
13062                 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
13063                 ETAIMJ=-EPS**2*PHIIM*FACHHH
13064               ENDIF
13065               ETARE=ETARE+ETAREJ
13066               ETAIM=ETAIM+ETAIMJ
13067   240       CONTINUE
13068             ETA2=ETARE**2+ETAIM**2
13069             WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
13070
13071           ELSEIF(I.EQ.15) THEN
13072 C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
13073             ETARE=0D0
13074             ETAIM=0D0
13075             JMAX=3*MSTP(1)+1
13076             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
13077             DO 250 J=1,JMAX
13078               IF(J.LE.2*MSTP(1)) THEN
13079                 EJ=KCHG(J,1)/3D0
13080                 AJ=SIGN(1D0,EJ+0.1D0)
13081                 VJ=AJ-4D0*EJ*XWV
13082                 EPS=(2D0*PMAS(J,1))**2/SH
13083                 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
13084               ELSEIF(J.LE.3*MSTP(1)) THEN
13085                 JL=2*(J-2*MSTP(1))-1
13086                 EJ=KCHG(10+JL,1)/3D0
13087                 AJ=SIGN(1D0,EJ+0.1D0)
13088                 VJ=AJ-4D0*EJ*XWV
13089                 EPS=(2D0*PMAS(10+JL,1))**2/SH
13090                 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
13091               ELSE
13092                 EPS=(2D0*PMAS(24,1))**2/SH
13093                 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
13094               ENDIF
13095 C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
13096               IF(EPS.LE.1D0) THEN
13097                 ROOT=SQRT(1D0-EPS)
13098                 IF(EPS.GT.1.D-4) THEN
13099                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13100                 ELSE
13101                   RLN=LOG(4D0/EPS-2D0)
13102                 ENDIF
13103                 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
13104                 PHIIM=0.5D0*PARU(1)*RLN
13105                 PSIRE=0.5D0*ROOT*RLN
13106                 PSIIM=-0.5D0*ROOT*PARU(1)
13107               ELSE
13108                 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
13109                 PHIIM=0D0
13110                 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
13111                 PSIIM=0D0
13112               ENDIF
13113               IF(EPSP.LE.1D0) THEN
13114                 ROOT=SQRT(1D0-EPSP)
13115                 IF(EPSP.GT.1.D-4) THEN
13116                   RLN=LOG((1D0+ROOT)/(1D0-ROOT))
13117                 ELSE
13118                   RLN=LOG(4D0/EPSP-2D0)
13119                 ENDIF
13120                 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
13121                 PHIIMP=0.5D0*PARU(1)*RLN
13122                 PSIREP=0.5D0*ROOT*RLN
13123                 PSIIMP=-0.5D0*ROOT*PARU(1)
13124               ELSE
13125                 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
13126                 PHIIMP=0D0
13127                 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
13128                 PSIIMP=0D0
13129               ENDIF
13130               FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
13131      &        (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
13132               FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
13133      &        (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
13134               F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
13135               F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
13136               IF(J.LE.3*MSTP(1)) THEN
13137 C...Fermion loops: loop integral different for A0; charges.
13138                 IF(IHIGG.EQ.3) FXYRE=0D0
13139                 IF(IHIGG.EQ.3) FXYIM=0D0
13140                 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
13141                   EJC=-3D0*EJ*VJ
13142                   EJH=PARU(151+10*IHIGG)
13143                 ELSEIF(J.LE.2*MSTP(1)) THEN
13144                   EJC=-3D0*EJ*VJ
13145                   EJH=PARU(152+10*IHIGG)
13146                 ELSE
13147                   EJC=-EJ*VJ
13148                   EJH=PARU(153+10*IHIGG)
13149                 ENDIF
13150                 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
13151                 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
13152                 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
13153               ELSEIF(J.EQ.3*MSTP(1)+1) THEN
13154 C...W loops: loop integral and charges.
13155                 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
13156                 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
13157                 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
13158                 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
13159                   ETAREJ=ETAREJ*PARU(155+10*IHIGG)
13160                   ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
13161                 ENDIF
13162               ELSE
13163 C...Charged H loops: loop integral and charges.
13164                 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
13165      &          PARU(158+10*IHIGG+2*(IHIGG/3))
13166                 ETAREJ=FACHHH*FXYRE
13167                 ETAIMJ=FACHHH*FXYIM
13168               ENDIF
13169               ETARE=ETARE+ETAREJ
13170               ETAIM=ETAIM+ETAIMJ
13171   250       CONTINUE
13172             ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
13173             WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
13174             WID2=WIDS(23,2)
13175
13176           ELSEIF(I.LE.17) THEN
13177 C...h0 -> Z0 + Z0, W+ + W-
13178             PM1=PMAS(IABS(KFDP(IDC,1)),1)
13179             PG1=PMAS(IABS(KFDP(IDC,1)),2)
13180             IF(MINT(62).GE.1) THEN
13181               IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
13182      &        CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
13183      &        MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
13184                 MOFSV(IHIGG,I-15)=0
13185                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13186      &          1D0-4D0*RM1))
13187                 WID2=1D0
13188               ELSE
13189                 MOFSV(IHIGG,I-15)=1
13190                 RMAS=SQRT(MAX(0D0,SH))
13191                 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
13192      &          WID2)
13193                 WIDWSV(IHIGG,I-15)=WIDW
13194                 WID2SV(IHIGG,I-15)=WID2
13195               ENDIF
13196             ELSE
13197               IF(MOFSV(IHIGG,I-15).EQ.0) THEN
13198                 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
13199      &          1D0-4D0*RM1))
13200                 WID2=1D0
13201               ELSE
13202                 WIDW=WIDWSV(IHIGG,I-15)
13203                 WID2=WID2SV(IHIGG,I-15)
13204               ENDIF
13205             ENDIF
13206             WDTP(I)=FAC*WIDW/(2D0*(18-I))
13207             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
13208      &      PARU(138+I+10*IHIGG)**2
13209             WID2=WID2*WIDS(7+I,1)
13210
13211           ELSEIF(I.EQ.18.AND.KFLA.EQ.35) THEN
13212 C***H0 -> Z0 + h0 (not yet implemented).
13213
13214           ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN
13215 C...H0 -> h0 + h0.
13216             WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2*
13217      &      SQRT(MAX(0D0,1D0-4D0*RM1))
13218             WID2=WIDS(25,2)**2
13219
13220           ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN
13221 C...H0 -> A0 + A0.
13222             WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2*
13223      &      SQRT(MAX(0D0,1D0-4D0*RM1))
13224             WID2=WIDS(36,2)**2
13225
13226           ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN
13227 C...A0 -> Z0 + h0.
13228             WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0,
13229      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13230             WID2=WIDS(23,2)*WIDS(25,2)
13231
13232 CMRENNA++
13233           ELSE
13234 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13235             RM10=RM1*SH/PMR**2
13236             RM20=RM2*SH/PMR**2
13237             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13238             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13239             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13240               WFAC=0D0
13241             ELSE
13242               WFAC=WFAC/WFAC0
13243             ENDIF
13244             WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13245 CMRENNA--
13246             IF(KFC2.EQ.KFC1) THEN
13247               WID2=WIDS(KFC1,1)
13248             ELSE
13249               KSGN1=2
13250               IF(KFDP(IDC,1).LT.0) KSGN1=3
13251               KSGN2=2
13252               IF(KFDP(IDC,2).LT.0) KSGN2=3
13253               WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13254             ENDIF
13255           ENDIF
13256           WDTP(0)=WDTP(0)+WDTP(I)
13257           IF(MDME(IDC,1).GT.0) THEN
13258             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13259             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13260             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13261             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13262           ENDIF
13263   260   CONTINUE
13264
13265       ELSEIF(KFLA.EQ.32) THEN
13266 C...Z'0:
13267         ICASE=1
13268         XWC=1D0/(16D0*XW*XW1)
13269         FAC=(AEM*XWC/3D0)*SHR
13270         VINT(117)=0D0
13271   270   CONTINUE
13272         IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
13273           VINT(111)=0D0
13274           VINT(112)=0D0
13275           VINT(113)=0D0
13276           VINT(114)=0D0
13277           VINT(115)=0D0
13278           VINT(116)=0D0
13279         ENDIF
13280         IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13281           KFAI=IABS(MINT(15))
13282           EI=KCHG(KFAI,1)/3D0
13283           AI=SIGN(1D0,EI+0.1D0)
13284           VI=AI-4D0*EI*XWV
13285           KFAIC=1
13286           IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
13287           IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
13288           IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
13289           VPI=PARU(119+2*KFAIC)
13290           API=PARU(120+2*KFAIC)
13291           SQMZ=PMAS(23,1)**2
13292           HZ=SHR*FAC*VINT(117)
13293           SQMZP=PMAS(32,1)**2
13294           HZP=SHR*FAC*WDTP(0)
13295           IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13296      &    MSTP(44).EQ.7) VINT(111)=1D0
13297           IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
13298      &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
13299           IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
13300      &    2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
13301           IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13302      &    MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
13303           IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
13304      &    2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
13305      &    (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
13306           IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13307      &    MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
13308         ENDIF
13309         DO 280 I=1,MDCY(KC,3)
13310           IDC=I+MDCY(KC,2)-1
13311           IF(MDME(IDC,1).LT.0) GOTO 280
13312           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13313           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13314           IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 280
13315           WID2=1D0
13316           IF(I.LE.16) THEN
13317             IF(I.LE.8) THEN
13318 C...Z'0 -> q + qbar
13319               EF=KCHG(I,1)/3D0
13320               AF=SIGN(1D0,EF+0.1D0)
13321               VF=AF-4D0*EF*XWV
13322               VPF=PARU(123-2*MOD(I,2))
13323               APF=PARU(124-2*MOD(I,2))
13324               FCOF=3D0*RADC
13325               IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
13326      &        PYHFTH(SH,SH*RM1,1D0)
13327               IF(I.EQ.6) WID2=WIDS(6,1)
13328               IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
13329             ELSEIF(I.LE.16) THEN
13330 C...Z'0 -> l+ + l-, nu + nubar
13331               EF=KCHG(I+2,1)/3D0
13332               AF=SIGN(1D0,EF+0.1D0)
13333               VF=AF-4D0*EF*XWV
13334               VPF=PARU(127-2*MOD(I,2))
13335               APF=PARU(128-2*MOD(I,2))
13336               FCOF=1D0
13337               IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
13338             ENDIF
13339             BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
13340             IF(ICASE.EQ.1) THEN
13341               WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13342               WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
13343      &        APF**2*(1D0-4D0*RM1))*BE34
13344             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13345               WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
13346      &        EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
13347      &        VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
13348      &        VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
13349      &        AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
13350      &        VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
13351             ELSEIF(MINT(61).EQ.2) THEN
13352               FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
13353               FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
13354               FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
13355               FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
13356               FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
13357      &        BE34
13358               FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
13359      &        BE34
13360             ENDIF
13361           ELSEIF(I.EQ.17) THEN
13362 C...Z'0 -> W+ + W-
13363             WDTPZP=PARU(129)**2*XW1**2*
13364      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13365      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13366             IF(ICASE.EQ.1) THEN
13367               WDTPZ=0D0
13368               WDTP(I)=FAC*WDTPZP
13369             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13370               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13371             ELSEIF(MINT(61).EQ.2) THEN
13372               FGGF=0D0
13373               FGZF=0D0
13374               FGZPF=0D0
13375               FZZF=0D0
13376               FZZPF=0D0
13377               FZPZPF=WDTPZP
13378             ENDIF
13379             WID2=WIDS(24,1)
13380           ELSEIF(I.EQ.18) THEN
13381 C...Z'0 -> H+ + H-
13382             CZC=2D0*(1D0-2D0*XW)
13383             BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
13384             IF(ICASE.EQ.1) THEN
13385               WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
13386               WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
13387             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13388               WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
13389      &        VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
13390      &        (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
13391      &        (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
13392      &        (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
13393             ELSEIF(MINT(61).EQ.2) THEN
13394               FGGF=0.25D0*BE34C
13395               FGZF=0.25D0*PARU(142)*CZC*BE34C
13396               FGZPF=0.25D0*PARU(143)*CZC*BE34C
13397               FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
13398               FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
13399               FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
13400             ENDIF
13401             WID2=WIDS(37,1)
13402           ELSEIF(I.EQ.19) THEN
13403 C...Z'0 -> Z0 + gamma.
13404           ELSEIF(I.EQ.20) THEN
13405 C...Z'0 -> Z0 + h0
13406             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13407             WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
13408      &      (3D0*RM1+0.25D0*FLAM**2)*FLAM
13409             IF(ICASE.EQ.1) THEN
13410               WDTPZ=0D0
13411               WDTP(I)=FAC*WDTPZP
13412             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13413               WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
13414             ELSEIF(MINT(61).EQ.2) THEN
13415               FGGF=0D0
13416               FGZF=0D0
13417               FGZPF=0D0
13418               FZZF=0D0
13419               FZZPF=0D0
13420               FZPZPF=WDTPZP
13421             ENDIF
13422             WID2=WIDS(23,2)*WIDS(25,2)
13423           ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
13424 C...Z' -> h0 + A0 or H0 + A0.
13425             BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13426             IF(I.EQ.21) THEN
13427               CZAH=PARU(186)
13428               CZPAH=PARU(188)
13429             ELSE
13430               CZAH=PARU(187)
13431               CZPAH=PARU(189)
13432             ENDIF
13433             IF(ICASE.EQ.1) THEN
13434               WDTPZ=CZAH**2*BE34C
13435               WDTP(I)=FAC*CZPAH**2*BE34C
13436             ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
13437               WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
13438      &        (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
13439      &        VINT(116))*BE34C
13440             ELSEIF(MINT(61).EQ.2) THEN
13441               FGGF=0D0
13442               FGZF=0D0
13443               FGZPF=0D0
13444               FZZF=CZAH**2*BE34C
13445               FZZPF=CZAH*CZPAH*BE34C
13446               FZPZPF=CZPAH**2*BE34C
13447             ENDIF
13448             IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
13449             IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
13450           ENDIF
13451           IF(ICASE.EQ.1) THEN
13452             VINT(117)=VINT(117)+WDTPZ
13453             WDTP(0)=WDTP(0)+WDTP(I)
13454           ENDIF
13455           IF(MDME(IDC,1).GT.0) THEN
13456             IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
13457      &      (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
13458               WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13459               WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
13460      &        WDTE(I,MDME(IDC,1))
13461               WDTE(I,0)=WDTE(I,MDME(IDC,1))
13462               WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13463             ENDIF
13464             IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
13465               IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
13466      &        MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
13467               IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
13468      &        FGZF*WID2
13469               IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
13470      &        FGZPF*WID2
13471               IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
13472      &        MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
13473               IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
13474      &        FZZPF*WID2
13475               IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
13476      &        MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
13477             ENDIF
13478           ENDIF
13479   280   CONTINUE
13480         IF(MINT(61).GE.1) ICASE=3-ICASE
13481         IF(ICASE.EQ.2) GOTO 270
13482
13483       ELSEIF(KFLA.EQ.34) THEN
13484 C...W'+/-:
13485         FAC=(AEM/(24D0*XW))*SHR
13486         DO 290 I=1,MDCY(KC,3)
13487           IDC=I+MDCY(KC,2)-1
13488           IF(MDME(IDC,1).LT.0) GOTO 290
13489           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13490           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13491           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 290
13492           WID2=1D0
13493           IF(I.LE.20) THEN
13494             IF(I.LE.16) THEN
13495 C...W'+/- -> q + qbar'
13496               FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
13497      &        VCKM((I-1)/4+1,MOD(I-1,4)+1)
13498               IF(KFLR.GT.0) THEN
13499                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
13500                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
13501                 IF(I.GE.13) WID2=WID2*WIDS(7,3)
13502               ELSE
13503                 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
13504                 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
13505                 IF(I.GE.13) WID2=WID2*WIDS(7,2)
13506               ENDIF
13507             ELSEIF(I.LE.20) THEN
13508 C...W'+/- -> l+/- + nu
13509               FCOF=PARU(133)**2+PARU(134)**2
13510               IF(KFLR.GT.0) THEN
13511                 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13512               ELSE
13513                 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13514               ENDIF
13515             ENDIF
13516             WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13517      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13518           ELSEIF(I.EQ.21) THEN
13519 C...W'+/- -> W+/- + Z0
13520             WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
13521      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
13522      &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
13523             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
13524             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
13525           ELSEIF(I.EQ.23) THEN
13526 C...W'+/- -> W+/- + h0
13527             FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13528             WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
13529             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13530             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13531           ENDIF
13532           WDTP(0)=WDTP(0)+WDTP(I)
13533           IF(MDME(IDC,1).GT.0) THEN
13534             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13535             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13536             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13537             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13538           ENDIF
13539   290   CONTINUE
13540
13541       ELSEIF(KFLA.EQ.37) THEN
13542 C...H+/-:
13543         FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR
13544         DO 300 I=1,MDCY(KC,3)
13545           IDC=I+MDCY(KC,2)-1
13546           IF(MDME(IDC,1).LT.0) GOTO 300
13547           KFC1=PYCOMP(KFDP(IDC,1))
13548           KFC2=PYCOMP(KFDP(IDC,2))
13549           RM1=PMAS(KFC1,1)**2/SH
13550           RM2=PMAS(KFC2,1)**2/SH
13551           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
13552           WID2=1D0
13553           IF(I.LE.4) THEN
13554 C...H+/- -> q + qbar'
13555             RM1R=RM1
13556             IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1*
13557      &      (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/
13558      &      LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
13559             WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)*
13560      &      (1D0-RM1R-RM2)-4D0*RM1R*RM2)*
13561      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13562             IF(KFLR.GT.0) THEN
13563               IF(I.EQ.3) WID2=WIDS(6,2)
13564               IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
13565             ELSE
13566               IF(I.EQ.3) WID2=WIDS(6,3)
13567               IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
13568             ENDIF
13569           ELSEIF(I.LE.8) THEN
13570 C...H+/- -> l+/- + nu
13571             WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
13572      &      (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-
13573      &      4D0*RM1*RM2))
13574             IF(KFLR.GT.0) THEN
13575               IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
13576             ELSE
13577               IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
13578             ENDIF
13579           ELSEIF(I.EQ.9) THEN
13580 C...H+/- -> W+/- + h0.
13581             WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
13582      &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13583             IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
13584             IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
13585
13586 CMRENNA++
13587           ELSE
13588 C...Add in SUSY decays (two-body) by rescaling by phase space factor.
13589             RM10=RM1*SH/PMR**2
13590             RM20=RM2*SH/PMR**2
13591             WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
13592             WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
13593             IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
13594               WFAC=0D0
13595             ELSE
13596               WFAC=WFAC/WFAC0
13597             ENDIF
13598             WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
13599 CMRENNA--
13600             KSGN1=2
13601             IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
13602             KSGN2=2
13603             IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
13604             WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
13605           ENDIF
13606           WDTP(0)=WDTP(0)+WDTP(I)
13607           IF(MDME(IDC,1).GT.0) THEN
13608             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13609             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13610             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13611             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13612           ENDIF
13613   300   CONTINUE
13614
13615       ELSEIF(KFLA.EQ.38) THEN
13616 C...Techni-eta.
13617         FAC=(SH/PARP(46)**2)*SHR
13618         DO 310 I=1,MDCY(KC,3)
13619           IDC=I+MDCY(KC,2)-1
13620           IF(MDME(IDC,1).LT.0) GOTO 310
13621           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13622           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13623           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
13624           WID2=1D0
13625           IF(I.LE.2) THEN
13626             WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
13627             IF(I.EQ.2) WID2=WIDS(6,1)
13628           ELSE
13629             WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
13630           ENDIF
13631           WDTP(0)=WDTP(0)+WDTP(I)
13632           IF(MDME(IDC,1).GT.0) THEN
13633             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13634             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13635             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13636             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13637           ENDIF
13638   310   CONTINUE
13639
13640       ELSEIF(KFLA.EQ.39) THEN
13641 C...LQ (leptoquark).
13642         FAC=(AEM/4D0)*PARU(151)*SHR
13643         DO 320 I=1,MDCY(KC,3)
13644           IDC=I+MDCY(KC,2)-1
13645           IF(MDME(IDC,1).LT.0) GOTO 320
13646           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13647           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13648           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
13649           WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13650           WID2=1D0
13651           WDTP(0)=WDTP(0)+WDTP(I)
13652           IF(MDME(IDC,1).GT.0) THEN
13653             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13654             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13655             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13656             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13657           ENDIF
13658   320   CONTINUE
13659
13660       ELSEIF(KFLA.EQ.40) THEN
13661 C...R:
13662         FAC=(AEM/(12D0*XW))*SHR
13663         DO 330 I=1,MDCY(KC,3)
13664           IDC=I+MDCY(KC,2)-1
13665           IF(MDME(IDC,1).LT.0) GOTO 330
13666           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13667           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13668           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
13669           WID2=1D0
13670           IF(I.LE.6) THEN
13671 C...R -> q + qbar'
13672             FCOF=3D0*RADC
13673           ELSEIF(I.LE.9) THEN
13674 C...R -> l+ + l'-
13675             FCOF=1D0
13676           ENDIF
13677           WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
13678      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13679           IF(KFLR.GT.0) THEN
13680             IF(I.EQ.4) WID2=WIDS(6,3)
13681             IF(I.EQ.5) WID2=WIDS(7,3)
13682             IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
13683             IF(I.EQ.9) WID2=WIDS(17,3)
13684           ELSE
13685             IF(I.EQ.4) WID2=WIDS(6,2)
13686             IF(I.EQ.5) WID2=WIDS(7,2)
13687             IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
13688             IF(I.EQ.9) WID2=WIDS(17,2)
13689           ENDIF
13690           WDTP(0)=WDTP(0)+WDTP(I)
13691           IF(MDME(IDC,1).GT.0) THEN
13692             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13693             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13694             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13695             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13696           ENDIF
13697   330   CONTINUE
13698
13699       ELSEIF(KFLA.EQ.51.OR.KFLA.EQ.52) THEN
13700 C...Techni-pi0 and techni-pi+-:
13701         FAC=(3D0/(32D0*PARU(1)*PARP(142)**2))*SHR
13702         DO 340 I=1,MDCY(KC,3)
13703           IDC=I+MDCY(KC,2)-1
13704           IF(MDME(IDC,1).LT.0) GOTO 340
13705           PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
13706           PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
13707           RM1=PM1**2/SH
13708           RM2=PM2**2/SH
13709           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
13710           WID2=1D0
13711 C...pi_tech -> f + f'.
13712           FCOF=1D0
13713           IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
13714           WDTP(I)=FAC*FCOF*(PM1+PM2)**2*
13715      &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13716           WDTP(0)=WDTP(0)+WDTP(I)
13717           IF(MDME(IDC,1).GT.0) THEN
13718             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13719             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13720             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13721             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13722           ENDIF
13723   340   CONTINUE
13724
13725       ELSEIF(KFLA.EQ.53) THEN
13726 C...Techni-pi'0 not yet implemented.
13727
13728       ELSEIF(KFLA.EQ.54) THEN
13729 C...Techni-rho0:
13730         ALPRHT=2.91D0*(3D0/PARP(144))
13731         FAC=(ALPRHT/12D0)*SHR
13732         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)
13733         SQMZ=PMAS(23,1)**2
13734         GMMZ=PMAS(23,1)*PMAS(23,2)
13735         XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
13736         BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13737         BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13738         DO 350 I=1,MDCY(KC,3)
13739           IDC=I+MDCY(KC,2)-1
13740           IF(MDME(IDC,1).LT.0) GOTO 350
13741           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13742           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13743           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 350
13744           IF(I.EQ.1) THEN
13745 C...rho_tech0 -> W+ + W-.
13746             WDTP(I)=FAC*PARP(141)**4*
13747      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13748             WID2=WIDS(24,1)
13749           ELSEIF(I.EQ.2) THEN
13750 C...rho_tech0 -> W+ + pi_tech-.
13751             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13752      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13753             WID2=WIDS(24,2)*WIDS(52,3)
13754           ELSEIF(I.EQ.3) THEN
13755 C...rho_tech0 -> pi_tech+ + W-.
13756             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13757      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13758             WID2=WIDS(52,2)*WIDS(24,3)
13759           ELSEIF(I.EQ.4) THEN
13760 C...rho_tech0 -> pi_tech+ + pi_tech-.
13761             WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13762      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13763             WID2=WIDS(52,1)
13764           ELSE
13765 C...rho_tech0 -> f + fbar.
13766             WID2=1D0
13767             IF(I.LE.12) THEN
13768               IA=I-4
13769               FCOF=3D0*RADC
13770               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13771             ELSE
13772               IA=I-2
13773               FCOF=1D0
13774               IF(IA.GE.17) WID2=WIDS(IA,1)
13775             ENDIF
13776             EI=KCHG(IA,1)/3D0
13777             AI=SIGN(1D0,EI+0.1D0)
13778             VI=AI-4D0*EI*XWV
13779             VALI=0.5D0*(VI+AI)
13780             VARI=0.5D0*(VI-AI)
13781             WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13782      &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
13783      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
13784           ENDIF
13785           WDTP(0)=WDTP(0)+WDTP(I)
13786           IF(MDME(IDC,1).GT.0) THEN
13787             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13788             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13789             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13790             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13791           ENDIF
13792   350   CONTINUE
13793
13794       ELSEIF(KFLA.EQ.55) THEN
13795 C...Techni-rho+/-:
13796         ALPRHT=2.91D0*(3D0/PARP(144))
13797         FAC=(ALPRHT/12D0)*SHR
13798         SQMW=PMAS(24,1)**2
13799         GMMW=PMAS(24,1)*PMAS(24,2)
13800         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13801      &  (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
13802         DO 360 I=1,MDCY(KC,3)
13803           IDC=I+MDCY(KC,2)-1
13804           IF(MDME(IDC,1).LT.0) GOTO 360
13805           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13806           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13807           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
13808           IF(I.EQ.1) THEN
13809 C...rho_tech+ -> W+ + Z0.
13810             WDTP(I)=FAC*PARP(141)**4*
13811      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13812             IF(KFLR.GT.0) THEN
13813               WID2=WIDS(24,2)*WIDS(23,2)
13814             ELSE
13815               WID2=WIDS(24,3)*WIDS(23,2)
13816             ENDIF
13817           ELSEIF(I.EQ.2) THEN
13818 C...rho_tech+ -> W+ + pi_tech0.
13819             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13820      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13821             IF(KFLR.GT.0) THEN
13822               WID2=WIDS(24,2)*WIDS(51,2)
13823             ELSE
13824               WID2=WIDS(24,3)*WIDS(51,2)
13825             ENDIF
13826           ELSEIF(I.EQ.3) THEN
13827 C...rho_tech+ -> pi_tech+ + Z0.
13828             WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)*
13829      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13830             IF(KFLR.GT.0) THEN
13831               WID2=WIDS(52,2)*WIDS(23,2)
13832             ELSE
13833               WID2=WIDS(52,3)*WIDS(23,2)
13834             ENDIF
13835           ELSEIF(I.EQ.4) THEN
13836 C...rho_tech+ -> pi_tech+ + pi_tech0.
13837             WDTP(I)=FAC*(1D0-PARP(141)**2)**2*
13838      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13839             IF(KFLR.GT.0) THEN
13840               WID2=WIDS(52,2)*WIDS(51,2)
13841             ELSE
13842               WID2=WIDS(52,3)*WIDS(51,2)
13843             ENDIF
13844           ELSE
13845 C...rho_tech+ -> f + fbar'.
13846             IA=I-4
13847             WID2=1D0
13848             IF(IA.LE.16) THEN
13849               FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
13850               IF(KFLR.GT.0) THEN
13851                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
13852                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
13853                 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
13854               ELSE
13855                 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
13856                 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
13857                 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
13858               ENDIF
13859             ELSE
13860               FCOF=1D0
13861               IF(KFLR.GT.0) THEN
13862                 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
13863               ELSE
13864                 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
13865               ENDIF
13866             ENDIF
13867             WDTP(I)=FACF*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
13868      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
13869           ENDIF
13870           WDTP(0)=WDTP(0)+WDTP(I)
13871           IF(MDME(IDC,1).GT.0) THEN
13872             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13873             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13874             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13875             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13876           ENDIF
13877   360   CONTINUE
13878
13879       ELSEIF(KFLA.EQ.56) THEN
13880 C...Techni-omega:
13881         ALPRHT=2.91D0*(3D0/PARP(144))
13882         FAC=(AEM/24D0)*(SHR**3/PARP(145)**2)
13883         FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)*
13884      &  (2D0*PARP(143)-1D0)**2
13885         SQMZ=PMAS(23,1)**2
13886         GMMZ=PMAS(23,1)*PMAS(23,2)
13887         BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
13888         BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
13889         DO 370 I=1,MDCY(KC,3)
13890           IDC=I+MDCY(KC,2)-1
13891           IF(MDME(IDC,1).LT.0) GOTO 370
13892           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13893           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13894           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
13895           IF(I.EQ.1) THEN
13896 C...omega_tech0 -> gamma + pi_tech0.
13897             WDTP(I)=FAC*
13898      &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
13899             WID2=WIDS(51,2)
13900           ELSEIF(I.EQ.2) THEN
13901 C...omega_tech0 -> Z0 + pi_tech0 not known.
13902             WDTP(I)=0D0
13903             WID2=WIDS(23,2)*WIDS(51,2)
13904           ELSE
13905 C...omega_tech0 -> f + fbar.
13906             WID2=1D0
13907             IF(I.LE.10) THEN
13908               IA=I-2
13909               FCOF=3D0*RADC
13910               IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
13911             ELSE
13912               IA=I
13913               FCOF=1D0
13914               IF(IA.GE.17) WID2=WIDS(IA,1)
13915             ENDIF
13916             EI=KCHG(IA,1)/3D0
13917             AI=SIGN(1D0,EI+0.1D0)
13918             VI=AI-4D0*EI*XWV
13919             VALI=0.5D0*(VI+AI)
13920             VARI=0.5D0*(VI-AI)
13921             WDTP(I)=FACF*FCOF*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))*
13922      &      ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
13923      &      (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
13924           ENDIF
13925           WDTP(0)=WDTP(0)+WDTP(I)
13926           IF(MDME(IDC,1).GT.0) THEN
13927             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13928             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13929             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13930             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13931           ENDIF
13932   370   CONTINUE
13933
13934       ELSEIF(KFLA.EQ.KEXCIT+1) THEN
13935 C...d* excited quark.
13936         FAC=(SH/PARU(155)**2)*SHR
13937         DO 380 I=1,MDCY(KC,3)
13938           IDC=I+MDCY(KC,2)-1
13939           IF(MDME(IDC,1).LT.0) GOTO 380
13940           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13941           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13942           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
13943           IF(I.EQ.1) THEN
13944 C...d* -> g + d.
13945             WDTP(I)=FAC*AS*PARU(159)**2/3D0
13946             WID2=1D0
13947           ELSEIF(I.EQ.2) THEN
13948 C...d* -> gamma + d.
13949             QF=-PARU(157)/2D0+PARU(158)/6D0
13950             WDTP(I)=FAC*AEM*QF**2/4D0
13951             WID2=1D0
13952           ELSEIF(I.EQ.3) THEN
13953 C...d* -> Z0 + d.
13954             QF=-PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13955             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13956      &      (1D0-RM1)**2*(2D0+RM1)
13957             WID2=WIDS(23,2)
13958           ELSEIF(I.EQ.4) THEN
13959 C...d* -> W- + u.
13960             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
13961      &      (1D0-RM1)**2*(2D0+RM1)
13962             IF(KFLR.GT.0) WID2=WIDS(24,3)
13963             IF(KFLR.LT.0) WID2=WIDS(24,2)
13964           ENDIF
13965           WDTP(0)=WDTP(0)+WDTP(I)
13966           IF(MDME(IDC,1).GT.0) THEN
13967             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
13968             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
13969             WDTE(I,0)=WDTE(I,MDME(IDC,1))
13970             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
13971           ENDIF
13972   380   CONTINUE
13973
13974       ELSEIF(KFLA.EQ.KEXCIT+2) THEN
13975 C...u* excited quark.
13976         FAC=(SH/PARU(155)**2)*SHR
13977         DO 390 I=1,MDCY(KC,3)
13978           IDC=I+MDCY(KC,2)-1
13979           IF(MDME(IDC,1).LT.0) GOTO 390
13980           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
13981           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
13982           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
13983           IF(I.EQ.1) THEN
13984 C...u* -> g + u.
13985             WDTP(I)=FAC*AS*PARU(159)**2/3D0
13986             WID2=1D0
13987           ELSEIF(I.EQ.2) THEN
13988 C...u* -> gamma + u.
13989             QF=PARU(157)/2D0+PARU(158)/6D0
13990             WDTP(I)=FAC*AEM*QF**2/4D0
13991             WID2=1D0
13992           ELSEIF(I.EQ.3) THEN
13993 C...u* -> Z0 + u.
13994             QF=PARU(157)*XW1/2D0-PARU(158)*XW/6D0
13995             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
13996      &      (1D0-RM1)**2*(2D0+RM1)
13997             WID2=WIDS(23,2)
13998           ELSEIF(I.EQ.4) THEN
13999 C...u* -> W+ + d.
14000             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14001      &      (1D0-RM1)**2*(2D0+RM1)
14002             IF(KFLR.GT.0) WID2=WIDS(24,2)
14003             IF(KFLR.LT.0) WID2=WIDS(24,3)
14004           ENDIF
14005           WDTP(0)=WDTP(0)+WDTP(I)
14006           IF(MDME(IDC,1).GT.0) THEN
14007             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14008             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14009             WDTE(I,0)=WDTE(I,MDME(IDC,1))
14010             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14011           ENDIF
14012   390   CONTINUE
14013
14014       ELSEIF(KFLA.EQ.KEXCIT+11) THEN
14015 C...e* excited lepton.
14016         FAC=(SH/PARU(155)**2)*SHR
14017         DO 400 I=1,MDCY(KC,3)
14018           IDC=I+MDCY(KC,2)-1
14019           IF(MDME(IDC,1).LT.0) GOTO 400
14020           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14021           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14022           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 400
14023           IF(I.EQ.1) THEN
14024 C...e* -> gamma + e.
14025             QF=-PARU(157)/2D0-PARU(158)/2D0
14026             WDTP(I)=FAC*AEM*QF**2/4D0
14027             WID2=1D0
14028           ELSEIF(I.EQ.2) THEN
14029 C...e* -> Z0 + e.
14030             QF=-PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14031             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14032      &      (1D0-RM1)**2*(2D0+RM1)
14033             WID2=WIDS(23,2)
14034           ELSEIF(I.EQ.3) THEN
14035 C...e* -> W- + nu.
14036             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14037      &      (1D0-RM1)**2*(2D0+RM1)
14038             IF(KFLR.GT.0) WID2=WIDS(24,3)
14039             IF(KFLR.LT.0) WID2=WIDS(24,2)
14040           ENDIF
14041           WDTP(0)=WDTP(0)+WDTP(I)
14042           IF(MDME(IDC,1).GT.0) THEN
14043             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14044             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14045             WDTE(I,0)=WDTE(I,MDME(IDC,1))
14046             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14047           ENDIF
14048   400   CONTINUE
14049
14050       ELSEIF(KFLA.EQ.KEXCIT+12) THEN
14051 C...nu*_e excited neutrino.
14052         FAC=(SH/PARU(155)**2)*SHR
14053         DO 410 I=1,MDCY(KC,3)
14054           IDC=I+MDCY(KC,2)-1
14055           IF(MDME(IDC,1).LT.0) GOTO 410
14056           RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
14057           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
14058           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
14059           IF(I.EQ.1) THEN
14060 C...nu*_e -> Z0 + nu*_e.
14061             QF=PARU(157)*XW1/2D0+PARU(158)*XW/2D0
14062             WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
14063      &      (1D0-RM1)**2*(2D0+RM1)
14064             WID2=WIDS(23,2)
14065           ELSEIF(I.EQ.2) THEN
14066 C...nu*_e -> W+ + e.
14067             WDTP(I)=FAC*AEM*PARU(157)**2/(16D0*XW)*
14068      &      (1D0-RM1)**2*(2D0+RM1)
14069             IF(KFLR.GT.0) WID2=WIDS(24,2)
14070             IF(KFLR.LT.0) WID2=WIDS(24,3)
14071           ENDIF
14072           WDTP(0)=WDTP(0)+WDTP(I)
14073           IF(MDME(IDC,1).GT.0) THEN
14074             WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
14075             WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
14076             WDTE(I,0)=WDTE(I,MDME(IDC,1))
14077             WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
14078           ENDIF
14079   410   CONTINUE
14080
14081       ENDIF
14082       MINT(61)=0
14083       MINT(62)=0
14084       MINT(63)=0
14085
14086       RETURN
14087       END
14088
14089 C***********************************************************************
14090
14091 *$ CREATE PYOFSH.FOR
14092 *COPY PYOFSH
14093 C...PYOFSH
14094 C...Calculates partial width and differential cross-section maxima
14095 C...of channels/processes not allowed on mass-shell, and selects
14096 C...masses in such channels/processes.
14097
14098       SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
14099
14100 C...Double precision and integer declarations.
14101       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14102       INTEGER PYK,PYCHGE,PYCOMP
14103 C...Commonblocks.
14104       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14105       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14106       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
14107       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
14108       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14109       COMMON/PYINT1/MINT(400),VINT(400)
14110       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14111       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14112       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
14113      &/PYINT2/,/PYINT5/
14114 C...Local arrays.
14115       DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
14116      &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
14117      &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:200),
14118      &WDTE(0:200,0:5)
14119
14120 C...Find if particles equal, maximum mass, matrix elements, etc.
14121       MINT(51)=0
14122       ISUB=MINT(1)
14123       KFD(1)=IABS(KFD1)
14124       KFD(2)=IABS(KFD2)
14125       MEQL=0
14126       IF(KFD(1).EQ.KFD(2)) MEQL=1
14127       MLM=0
14128       IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
14129       IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
14130         NOFF=44
14131         PMMX=PMMO
14132       ELSE
14133         NOFF=40
14134         PMMX=VINT(1)
14135         IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
14136       ENDIF
14137       MMED=0
14138       IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
14139      &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
14140       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
14141      &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
14142       IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
14143      &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
14144       LOOP=1
14145
14146 C...Find where Breit-Wigners are required, else select discrete masses.
14147   100 DO 110 I=1,2
14148         KFCA=PYCOMP(KFD(I))
14149         IF(KFCA.GT.0) THEN
14150           PMD(I)=PMAS(KFCA,1)
14151           PGD(I)=PMAS(KFCA,2)
14152         ELSE
14153           PMD(I)=0D0
14154           PGD(I)=0D0
14155         ENDIF
14156         IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
14157           MBW(I)=0
14158           PMG(I)=PMD(I)
14159           RMG(I)=(PMG(I)/PMMX)**2
14160         ELSE
14161           MBW(I)=1
14162         ENDIF
14163   110 CONTINUE
14164
14165 C...Find allowed mass range and Breit-Wigner parameters.
14166       DO 120 I=1,2
14167         IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
14168           PML(I)=PARP(42)
14169           PMU(I)=PMMX-PARP(42)
14170           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14171           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14172         ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
14173           ILM=I
14174           IF(MLM.EQ.2) ILM=3-I
14175           PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
14176           PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
14177           IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I),
14178      &    CKIN(NOFF+2*ILM))
14179           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14180           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14181           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14182           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14183           IF(MBW(I).EQ.1) THEN
14184             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14185             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14186             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14187      &      PGD(I)))
14188           ENDIF
14189         ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
14190           ILM=I
14191           IF(MLM.EQ.2) ILM=3-I
14192           PML(I)=MAX(CKIN(48+I),PARP(42))
14193           PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
14194           IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
14195           IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
14196           IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
14197           IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
14198           IF(MBW(I).EQ.1) THEN
14199             ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14200             ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
14201             IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
14202      &      PGD(I)))
14203           ENDIF
14204         ENDIF
14205   120 CONTINUE
14206       IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
14207      &THEN
14208         CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
14209         MINT(51)=1
14210         RETURN
14211       ENDIF
14212
14213 C...Calculation of partial width of resonance.
14214       IF(MOFSH.EQ.1) THEN
14215
14216 C..If only one integration, pick that to be the inner.
14217         IF(MBW(1).EQ.0) THEN
14218           PM2=PMD(1)
14219           PMD(1)=PMD(2)
14220           PGD(1)=PGD(2)
14221           PML(1)=PML(2)
14222           PMU(1)=PMU(2)
14223         ELSEIF(MBW(2).EQ.0) THEN
14224           PM2=PMD(2)
14225         ENDIF
14226
14227 C...Start outer loop of integration.
14228         IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14229           ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14230           ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
14231           NPT2=1
14232           XPT2(1)=1D0
14233           INX2(1)=0
14234           FMAX2=0D0
14235         ENDIF
14236   130   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14237           PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
14238           PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
14239         ENDIF
14240         RM2=(PM2/PMMX)**2
14241
14242 C...Start inner loop of integration.
14243         PML1=PML(1)
14244         PMU1=MIN(PMU(1),PMMX-PM2)
14245         IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
14246         ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14247         ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
14248         IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
14249           FUNC2=0D0
14250           GOTO 180
14251         ENDIF
14252         NPT1=1
14253         XPT1(1)=1D0
14254         INX1(1)=0
14255         FMAX1=0D0
14256   140   PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
14257         PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
14258         RM1=(PM1/PMMX)**2
14259
14260 C...Evaluate function value - inner loop.
14261         FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
14262         IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
14263         IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
14264      &  RM2**2+10D0*RM1*RM2)
14265         IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
14266         FPT1(NPT1)=FUNC1
14267
14268 C...Go to next position in inner loop.
14269         IF(NPT1.EQ.1) THEN
14270           NPT1=NPT1+1
14271           XPT1(NPT1)=0D0
14272           INX1(NPT1)=1
14273           GOTO 140
14274         ELSEIF(NPT1.LE.8) THEN
14275           NPT1=NPT1+1
14276           IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
14277           ISH1=ISH1+1
14278           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14279           INX1(NPT1)=INX1(ISH1)
14280           INX1(ISH1)=NPT1
14281           GOTO 140
14282         ELSEIF(NPT1.LT.100) THEN
14283           ISN1=ISH1
14284   150     ISH1=ISH1+1
14285           IF(ISH1.GT.NPT1) ISH1=2
14286           IF(ISH1.EQ.ISN1) GOTO 160
14287           DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
14288           IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
14289           NPT1=NPT1+1
14290           XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
14291           INX1(NPT1)=INX1(ISH1)
14292           INX1(ISH1)=NPT1
14293           GOTO 140
14294         ENDIF
14295
14296 C...Calculate integral over inner loop.
14297   160   FSUM1=0D0
14298         DO 170 IPT1=2,NPT1
14299           FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
14300      &    (XPT1(INX1(IPT1))-XPT1(IPT1))
14301   170   CONTINUE
14302         FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
14303   180   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
14304           IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
14305           FPT2(NPT2)=FUNC2
14306
14307 C...Go to next position in outer loop.
14308           IF(NPT2.EQ.1) THEN
14309             NPT2=NPT2+1
14310             XPT2(NPT2)=0D0
14311             INX2(NPT2)=1
14312             GOTO 130
14313           ELSEIF(NPT2.LE.8) THEN
14314             NPT2=NPT2+1
14315             IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
14316             ISH2=ISH2+1
14317             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14318             INX2(NPT2)=INX2(ISH2)
14319             INX2(ISH2)=NPT2
14320             GOTO 130
14321           ELSEIF(NPT2.LT.100) THEN
14322             ISN2=ISH2
14323   190       ISH2=ISH2+1
14324             IF(ISH2.GT.NPT2) ISH2=2
14325             IF(ISH2.EQ.ISN2) GOTO 200
14326             DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
14327             IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
14328             NPT2=NPT2+1
14329             XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
14330             INX2(NPT2)=INX2(ISH2)
14331             INX2(ISH2)=NPT2
14332             GOTO 130
14333           ENDIF
14334
14335 C...Calculate integral over outer loop.
14336   200     FSUM2=0D0
14337           DO 210 IPT2=2,NPT2
14338             FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
14339      &      (XPT2(INX2(IPT2))-XPT2(IPT2))
14340   210     CONTINUE
14341           FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
14342           IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
14343         ELSE
14344           FSUM2=FUNC2
14345         ENDIF
14346
14347 C...Save result; second integration for user-selected mass range.
14348         IF(LOOP.EQ.1) WIDW=FSUM2
14349         WID2=FSUM2
14350         IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
14351      &  .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
14352           LOOP=2
14353           GOTO 100
14354         ENDIF
14355         RET1=WIDW
14356         RET2=WID2/WIDW
14357
14358 C...Select two decay product masses of a resonance.
14359       ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
14360   220   DO 230 I=1,2
14361           IF(MBW(I).EQ.0) GOTO 230
14362           PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
14363      &    (ATU(I)-ATL(I)))
14364           PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
14365           RMG(I)=(PMG(I)/PMMX)**2
14366   230   CONTINUE
14367         IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14368      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
14369
14370 C...Weight with matrix element (if none known, use beta factor).
14371         FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
14372         IF(MMED.EQ.1) THEN
14373           WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
14374         ELSEIF(MMED.EQ.2) THEN
14375           WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
14376      &    RMG(2)**2+10D0*RMG(1)*RMG(2))
14377         ELSEIF(MMED.EQ.3) THEN
14378           WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
14379         ELSE
14380           WTBE=FLAM
14381         ENDIF
14382         IF(WTBE.LT.PYR(0)) GOTO 220
14383         RET1=PMG(1)
14384         RET2=PMG(2)
14385
14386 C...Find suitable set of masses for initialization of 2 -> 2 processes.
14387       ELSEIF(MOFSH.EQ.3) THEN
14388         IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
14389           PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
14390           PMG(2)=PMD(2)
14391         ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
14392           PMG(1)=PMD(1)
14393           PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
14394         ELSE
14395           IDIV=-1
14396   240     IDIV=IDIV+1
14397           PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
14398           PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
14399           IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
14400         ENDIF
14401         RET1=PMG(1)
14402         RET2=PMG(2)
14403
14404 C...Evaluate importance of excluded tails of Breit-Wigners.
14405         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14406      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14407         IF(MEQL.LE.1) THEN
14408           VINT(80)=1D0
14409           DO 250 I=1,2
14410             IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
14411      &      PARU(1)
14412   250     CONTINUE
14413         ELSE
14414           VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
14415      &    (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
14416         ENDIF
14417         IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
14418      &  MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
14419         IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
14420         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14421
14422 C...Pick one particle to be the lighter (if improves efficiency).
14423       ELSEIF(MOFSH.EQ.4) THEN
14424         IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
14425      &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
14426   260   IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
14427
14428 C...Select two masses according to Breit-Wigner + flat in s + 1/s.
14429         DO 270 I=1,2
14430           IF(MBW(I).EQ.0) GOTO 270
14431           PMV=PMU(I)
14432           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14433           ATV=ATU(I)
14434           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14435           RBR=PYR(0)
14436           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14437      &    ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
14438           IF(RBR.LT.0.8D0) THEN
14439             PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
14440             PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
14441           ELSEIF(RBR.LT.0.9D0) THEN
14442             PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
14443           ELSEIF(RBR.LT.1.5D0) THEN
14444             PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
14445           ELSE
14446             PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
14447      &      (PMV**2-PML(I)**2))))
14448           ENDIF
14449   270   CONTINUE
14450         IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
14451      &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
14452           IF(MINT(48).EQ.1) THEN
14453             NGEN(0,1)=NGEN(0,1)+1
14454             NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
14455             GOTO 260
14456           ELSE
14457             MINT(51)=1
14458             RETURN
14459           ENDIF
14460         ENDIF
14461         RET1=PMG(1)
14462         RET2=PMG(2)
14463
14464 C...Give weight for selected mass distribution.
14465         VINT(80)=1D0
14466         DO 280 I=1,2
14467           IF(MBW(I).EQ.0) GOTO 280
14468           PMV=PMU(I)
14469           IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
14470           ATV=ATU(I)
14471           IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
14472           F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
14473      &    (PMD(I)*PGD(I))**2)/PARU(1)
14474           F1=1D0
14475           F2=1D0/PMG(I)**2
14476           F3=1D0/PMG(I)**4
14477           FI0=(ATV-ATL(I))/PARU(1)
14478           FI1=PMV**2-PML(I)**2
14479           FI2=2D0*LOG(PMV/PML(I))
14480           FI3=1D0/PML(I)**2-1D0/PMV**2
14481           IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
14482      &    ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
14483             VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
14484      &      5D0*F3/FI3))
14485           ELSE
14486             VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
14487           ENDIF
14488           VINT(80)=VINT(80)*FI0
14489   280   CONTINUE
14490         IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
14491       ENDIF
14492
14493       RETURN
14494       END
14495
14496 C***********************************************************************
14497
14498 *$ CREATE PYRECO.FOR
14499 *COPY PYRECO
14500 C...PYRECO
14501 C...Handles the possibility of colour reconnection in W+W- events,
14502 C...Based on the main scenarios of the Sjostrand and Khoze study:
14503 C...I, II, II', intermediate and instantaneous; plus one model
14504 C...along the lines of the Gustafson and Hakkinen: GH.
14505
14506       SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
14507
14508 C...Double precision and integer declarations.
14509       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14510       INTEGER PYK,PYCHGE,PYCOMP
14511 C...Parameter value; number of points in MC integration.
14512       PARAMETER (NPT=100)
14513 C...Commonblocks.
14514       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14515       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14516       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14517       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14518       COMMON/PYINT1/MINT(400),VINT(400)
14519       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
14520 C...Local arrays.
14521       DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
14522      &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
14523      &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
14524      &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
14525      &TMC(20),IJOIN(100)
14526
14527 C...Functions to give four-product and to do determinants.
14528       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)
14529       DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
14530      &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
14531      &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
14532
14533 C...Only allow fraction of recoupling for GH, intermediate and
14534 C...instantaneous.
14535       IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14536         IF(PYR(0).GT.PARP(120)) RETURN
14537       ENDIF
14538
14539 C...Common part for scenarios I, II, II', and GH.
14540       IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
14541      &MSTP(115).EQ.5) THEN
14542
14543 C...Read out frequently-used parameters.
14544         PI=PARU(1)
14545         HBAR=PARU(3)
14546         PMW=PMAS(24,1)
14547         PGW=PMAS(24,2)
14548         TFRAG=PARP(115)
14549         RHAD=PARP(116)
14550         FACT=PARP(117)
14551         BLOWR=PARP(118)
14552         BLOWT=PARP(119)
14553
14554 C...Find range of decay products of the W's.
14555 C...Background: the W's are stored in IW1 and IW2.
14556 C...Their direct decay products in NSD1+1 through NSD1+4.
14557 C...Products after shower (if any) in NSD1+5 through NAFT1
14558 C...for first W and in NAFT1+1 through N for the second.
14559         IF(K(IW1,2).GT.0) THEN
14560           JT=1
14561         ELSE
14562           JT=2
14563         ENDIF
14564         JR=3-JT
14565         IF(NAFT1.GT.NSD1+4) THEN
14566           NBEG(JT)=NSD1+5
14567           NEND(JT)=NAFT1
14568         ELSE
14569           NBEG(JT)=NSD1+1
14570           NEND(JT)=NSD1+2
14571         ENDIF
14572         IF(N.GT.NAFT1) THEN
14573           NBEG(JR)=NAFT1+1
14574           NEND(JR)=N
14575         ELSE
14576           NBEG(JR)=NSD1+3
14577           NEND(JR)=NSD1+4
14578         ENDIF
14579
14580 C...Rearrange parton shower products along strings.
14581         NOLD=N
14582         CALL PYPREP(NSD1+1)
14583
14584 C...Find partons pointing back to W+ and W-; store them with quark
14585 C...end of string first.
14586         NNP=0
14587         NNM=0
14588         ISGP=0
14589         ISGM=0
14590         DO 120 I=NOLD+1,N
14591           IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
14592           IF(IABS(K(I,2)).GE.22) GOTO 120
14593           IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
14594             IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
14595             NNP=NNP+1
14596             IF(ISGP.EQ.1) THEN
14597               INP(NNP)=I
14598             ELSE
14599               DO 100 I1=NNP,2,-1
14600                 INP(I1)=INP(I1-1)
14601   100         CONTINUE
14602               INP(1)=I
14603             ENDIF
14604             IF(K(I,1).EQ.1) ISGP=0
14605           ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
14606             IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
14607             NNM=NNM+1
14608             IF(ISGM.EQ.1) THEN
14609               INM(NNM)=I
14610             ELSE
14611               DO 110 I1=NNM,2,-1
14612                 INM(I1)=INM(I1-1)
14613   110         CONTINUE
14614               INM(1)=I
14615             ENDIF
14616             IF(K(I,1).EQ.1) ISGM=0
14617           ENDIF
14618   120   CONTINUE
14619
14620 C...Boost to W+W- rest frame (not strictly needed).
14621         DO 130 J=1,3
14622           BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
14623   130   CONTINUE
14624         CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14625         CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14626         CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
14627
14628 C...Select decay vertices of W+ and W-.
14629         TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
14630      &  SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
14631         TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
14632      &  SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
14633         GTMAX=MAX(TP,TM)
14634         DO 140 J=1,3
14635           XP(J)=TP*P(IW1,J)/P(IW1,4)
14636           XM(J)=TM*P(IW2,J)/P(IW2,4)
14637   140   CONTINUE
14638
14639 C...Begin scenario I specifics.
14640         IF(MSTP(115).EQ.1) THEN
14641
14642 C...Reconstruct velocity and direction of W+ string pieces.
14643           DO 170 IIP=1,NNP-1
14644             IF(K(INP(IIP),2).LT.0) GOTO 170
14645             I1=INP(IIP)
14646             I2=INP(IIP+1)
14647             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14648             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14649             DO 150 J=1,3
14650               V1(J)=P(I1,J)/P1A
14651               V2(J)=P(I2,J)/P2A
14652               BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
14653               DIRP(IIP,J)=V1(J)-V2(J)
14654   150       CONTINUE
14655             BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
14656      &      BETP(IIP,3)**2)
14657             DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
14658             DO 160 J=1,3
14659               DIRP(IIP,J)=DIRP(IIP,J)/DIRL
14660   160       CONTINUE
14661   170     CONTINUE
14662
14663 C...Reconstruct velocity and direction of W- string pieces.
14664           DO 200 IIM=1,NNM-1
14665             IF(K(INM(IIM),2).LT.0) GOTO 200
14666             I1=INM(IIM)
14667             I2=INM(IIM+1)
14668             P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
14669             P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
14670             DO 180 J=1,3
14671               V1(J)=P(I1,J)/P1A
14672               V2(J)=P(I2,J)/P2A
14673               BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
14674               DIRM(IIM,J)=V1(J)-V2(J)
14675   180       CONTINUE
14676             BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
14677      &      BETM(IIM,3)**2)
14678             DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
14679             DO 190 J=1,3
14680               DIRM(IIM,J)=DIRM(IIM,J)/DIRL
14681   190       CONTINUE
14682   200     CONTINUE
14683
14684 C...Loop over number of space-time points.
14685           NACC=0
14686           SUM=0D0
14687           DO 250 IPT=1,NPT
14688
14689 C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
14690             R=SQRT(-LOG(PYR(0)))
14691             PHI=2D0*PI*PYR(0)
14692             X=BLOWR*RHAD*R*COS(PHI)
14693             Y=BLOWR*RHAD*R*SIN(PHI)
14694             R=SQRT(-LOG(PYR(0)))
14695             PHI=2D0*PI*PYR(0)
14696             Z=BLOWR*RHAD*R*COS(PHI)
14697             T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
14698
14699 C...Weight for sample distribution.
14700             WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
14701      &      EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
14702
14703 C...Loop over W+ string pieces and find one with largest weight.
14704             IMAXP=0
14705             WTMAXP=1D-10
14706             XD(1)=X-XP(1)
14707             XD(2)=Y-XP(2)
14708             XD(3)=Z-XP(3)
14709             XD(4)=T-TP
14710             DO 220 IIP=1,NNP-1
14711               IF(K(INP(IIP),2).LT.0) GOTO 220
14712               BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
14713               BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
14714               DO 210 J=1,3
14715                 XB(J)=XD(J)+BEDG*BETP(IIP,J)
14716   210         CONTINUE
14717               XB(4)=BETP(IIP,4)*(XD(4)-BED)
14718               SR2=XB(1)**2+XB(2)**2+XB(3)**2
14719               SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
14720      &        DIRP(IIP,3)*XB(3))**2
14721               WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14722      &        TFRAG**2)
14723               IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
14724               IF(WTP.GT.WTMAXP) THEN
14725                 IMAXP=IIP
14726                 WTMAXP=WTP
14727               ENDIF
14728   220       CONTINUE
14729
14730 C...Loop over W- string pieces and find one with largest weight.
14731             IMAXM=0
14732             WTMAXM=1D-10
14733             XD(1)=X-XM(1)
14734             XD(2)=Y-XM(2)
14735             XD(3)=Z-XM(3)
14736             XD(4)=T-TM
14737             DO 240 IIM=1,NNM-1
14738               IF(K(INM(IIM),2).LT.0) GOTO 240
14739               BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
14740               BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
14741               DO 230 J=1,3
14742                 XB(J)=XD(J)+BEDG*BETM(IIM,J)
14743   230         CONTINUE
14744               XB(4)=BETM(IIM,4)*(XD(4)-BED)
14745               SR2=XB(1)**2+XB(2)**2+XB(3)**2
14746               SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
14747      &        DIRM(IIM,3)*XB(3))**2
14748               WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
14749      &        TFRAG**2)
14750               IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
14751               IF(WTM.GT.WTMAXM) THEN
14752                 IMAXM=IIM
14753                 WTMAXM=WTM
14754               ENDIF
14755   240       CONTINUE
14756
14757 C...Result of integration.
14758             WT=0D0
14759             IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
14760               WT=WTMAXP*WTMAXM/WTSMP
14761               SUM=SUM+WT
14762               NACC=NACC+1
14763               IAP(NACC)=IMAXP
14764               IAM(NACC)=IMAXM
14765               WTA(NACC)=WT
14766             ENDIF
14767   250     CONTINUE
14768           RES=BLOWR**3*BLOWT*SUM/NPT
14769
14770 C...Decide whether to reconnect and, if so, where.
14771           IACC=0
14772           PREC=1D0-EXP(-FACT*RES)
14773           IF(PREC.GT.PYR(0)) THEN
14774             RSUM=PYR(0)*SUM
14775             DO 260 IA=1,NACC
14776               IACC=IA
14777               RSUM=RSUM-WTA(IA)
14778               IF(RSUM.LE.0D0) GOTO 270
14779   260       CONTINUE
14780   270       IIP=IAP(IACC)
14781             IIM=IAM(IACC)
14782           ENDIF
14783
14784 C...Begin scenario II and II' specifics.
14785         ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
14786
14787 C...Loop through all string pieces, one from W+ and one from W-.
14788           NCROSS=0
14789           TC(0)=0D0
14790           DO 340 IIP=1,NNP-1
14791             IF(K(INP(IIP),2).LT.0) GOTO 340
14792             I1P=INP(IIP)
14793             I2P=INP(IIP+1)
14794             DO 330 IIM=1,NNM-1
14795               IF(K(INM(IIM),2).LT.0) GOTO 330
14796               I1M=INM(IIM)
14797               I2M=INM(IIM+1)
14798
14799 C...Find endpoint velocity vectors.
14800               DO 280 J=1,3
14801                 V1P(J)=P(I1P,J)/P(I1P,4)
14802                 V2P(J)=P(I2P,J)/P(I2P,4)
14803                 V1M(J)=P(I1M,J)/P(I1M,4)
14804                 V2M(J)=P(I2M,J)/P(I2M,4)
14805   280         CONTINUE
14806
14807 C...Define q matrix and find t.
14808               DO 290 J=1,3
14809                 Q(1,J)=V2P(J)-V1P(J)
14810                 Q(2,J)=-(V2M(J)-V1M(J))
14811                 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
14812                 Q(4,J)=V1P(J)-V1M(J)
14813   290         CONTINUE
14814               T=-DETER(1,2,3)/DETER(1,2,4)
14815
14816 C...Find alpha and beta; i.e. coordinates of crossing point.
14817               S11=Q(1,1)*(T-TP)
14818               S12=Q(2,1)*(T-TM)
14819               S13=Q(3,1)+Q(4,1)*T
14820               S21=Q(1,2)*(T-TP)
14821               S22=Q(2,2)*(T-TM)
14822               S23=Q(3,2)+Q(4,2)*T
14823               DEN=S11*S22-S12*S21
14824               ALP=(S12*S23-S22*S13)/DEN
14825               BET=(S21*S13-S11*S23)/DEN
14826
14827 C...Check if solution acceptable.
14828               IANSW=1
14829               IF(T.LT.GTMAX) IANSW=0
14830               IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
14831               IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
14832
14833 C...Find point of crossing and check that not inconsistent.
14834               DO 300 J=1,3
14835                 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
14836                 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
14837   300         CONTINUE
14838               D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
14839      &        (XPP(3)-XMM(3))**2
14840               D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
14841               D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
14842               IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
14843
14844 C...Find string eigentimes at crossing.
14845               IF(IANSW.EQ.1) THEN
14846                 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
14847      &          (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
14848                 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
14849      &          (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
14850               ELSE
14851                 TAUP=0D0
14852                 TAUM=0D0
14853               ENDIF
14854
14855 C...Order crossings by time. End loop over crossings.
14856               IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
14857                 NCROSS=NCROSS+1
14858                 DO 310 I1=NCROSS,1,-1
14859                   IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
14860                     IPC(I1)=IIP
14861                     IMC(I1)=IIM
14862                     TC(I1)=T
14863                     TPC(I1)=TAUP
14864                     TMC(I1)=TAUM
14865                     GOTO 320
14866                   ELSE
14867                     IPC(I1)=IPC(I1-1)
14868                     IMC(I1)=IMC(I1-1)
14869                     TC(I1)=TC(I1-1)
14870                     TPC(I1)=TPC(I1-1)
14871                     TMC(I1)=TMC(I1-1)
14872                   ENDIF
14873   310           CONTINUE
14874   320           CONTINUE
14875               ENDIF
14876   330       CONTINUE
14877   340     CONTINUE
14878
14879 C...Loop over crossings; find first (if any) acceptable one.
14880           IACC=0
14881           IF(NCROSS.GE.1) THEN
14882             DO 350 IC=1,NCROSS
14883               PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
14884               IF(PNFRAG.GT.PYR(0)) THEN
14885 C...Scenario II: only compare with fragmentation time.
14886                 IF(MSTP(115).EQ.2) THEN
14887                   IACC=IC
14888                   IIP=IPC(IACC)
14889                   IIM=IMC(IACC)
14890                   GOTO 360
14891 C...Scenario II': also require that string length decreases.
14892                 ELSE
14893                   IIP=IPC(IC)
14894                   IIM=IMC(IC)
14895                   I1P=INP(IIP)
14896                   I2P=INP(IIP+1)
14897                   I1M=INM(IIM)
14898                   I2M=INM(IIM+1)
14899                   ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14900                   ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14901                   IF(ELNEW.LT.ELOLD) THEN
14902                     IACC=IC
14903                     IIP=IPC(IACC)
14904                     IIM=IMC(IACC)
14905                     GOTO 360
14906                   ENDIF
14907                 ENDIF
14908               ENDIF
14909   350       CONTINUE
14910   360       CONTINUE
14911           ENDIF
14912
14913 C...Begin scenario GH specifics.
14914         ELSEIF(MSTP(115).EQ.5) THEN
14915
14916 C...Loop through all string pieces, one from W+ and one from W-.
14917           IACC=0
14918           ELMIN=1D0
14919           DO 380 IIP=1,NNP-1
14920             IF(K(INP(IIP),2).LT.0) GOTO 380
14921             I1P=INP(IIP)
14922             I2P=INP(IIP+1)
14923             DO 370 IIM=1,NNM-1
14924               IF(K(INM(IIM),2).LT.0) GOTO 370
14925               I1M=INM(IIM)
14926               I2M=INM(IIM+1)
14927
14928 C...Look for largest decrease of (exponent of) Lambda measure.
14929               ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
14930               ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
14931               ELDIF=ELNEW/MAX(1D-10,ELOLD)
14932               IF(ELDIF.LT.ELMIN) THEN
14933                 IACC=IIP+IIM
14934                 ELMIN=ELDIF
14935                 IPC(1)=IIP
14936                 IMC(1)=IIM
14937               ENDIF
14938   370       CONTINUE
14939   380     CONTINUE
14940           IIP=IPC(1)
14941           IIM=IMC(1)
14942         ENDIF
14943
14944 C...Common for scenarios I, II, II' and GH: reconnect strings.
14945         IF(IACC.NE.0) THEN
14946           MINT(32)=1
14947           NJOIN=0
14948           DO 390 IS=1,NNP+NNM
14949             NJOIN=NJOIN+1
14950             IF(IS.LE.IIP) THEN
14951               I=INP(IS)
14952             ELSEIF(IS.LE.IIP+NNM-IIM) THEN
14953               I=INM(IS-IIP+IIM)
14954             ELSEIF(IS.LE.IIP+NNM) THEN
14955               I=INM(IS-IIP-NNM+IIM)
14956             ELSE
14957               I=INP(IS-NNM)
14958             ENDIF
14959             IJOIN(NJOIN)=I
14960             IF(K(I,2).LT.0) THEN
14961               CALL PYJOIN(NJOIN,IJOIN)
14962               NJOIN=0
14963             ENDIF
14964   390     CONTINUE
14965
14966 C...Restore original event record if no reconnection.
14967         ELSE
14968           DO 400 I=NSD1+1,NOLD
14969             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
14970               K(I,4)=MOD(K(I,4),MSTU(5)**2)
14971               K(I,5)=MOD(K(I,5),MSTU(5)**2)
14972             ENDIF
14973   400     CONTINUE
14974           DO 410 I=NOLD+1,N
14975             K(K(I,3),1)=3
14976   410     CONTINUE
14977           N=NOLD
14978         ENDIF
14979
14980 C...Boost back system.
14981         CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14982         CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
14983         IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
14984      &  BEWW(1),BEWW(2),BEWW(3))
14985
14986 C...Common part for intermediate and instantaneous scenarios.
14987       ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
14988         MINT(32)=1
14989
14990 C...Remove old shower products and reset showering ones.
14991         N=NSD1+4
14992         DO 420 I=NSD1+1,NSD1+4
14993           K(I,1)=3
14994           K(I,4)=MOD(K(I,4),MSTU(5)**2)
14995           K(I,5)=MOD(K(I,5),MSTU(5)**2)
14996   420   CONTINUE
14997
14998 C...Identify quark-antiquark pairs.
14999         IQ1=NSD1+1
15000         IQ2=NSD1+2
15001         IQ3=NSD1+3
15002         IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
15003         IQ4=2*NSD1+7-IQ3
15004
15005 C...Reconnect strings.
15006         IJOIN(1)=IQ1
15007         IJOIN(2)=IQ4
15008         CALL PYJOIN(2,IJOIN)
15009         IJOIN(1)=IQ3
15010         IJOIN(2)=IQ2
15011         CALL PYJOIN(2,IJOIN)
15012
15013 C...Do new parton showers in intermediate scenario.
15014         IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
15015           MSTJ50=MSTJ(50)
15016           MSTJ(50)=0
15017           CALL PYSHOW(IQ1,IQ2,P(IW1,5))
15018           CALL PYSHOW(IQ3,IQ4,P(IW2,5))
15019           MSTJ(50)=MSTJ50
15020
15021 C...Do new parton showers in instantaneous scenario.
15022         ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
15023           PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
15024      &    (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
15025           PPM=SQRT(MAX(0D0,PPM2))
15026           CALL PYSHOW(IQ1,IQ4,PPM)
15027           PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
15028      &    (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
15029           PPM=SQRT(MAX(0D0,PPM2))
15030           CALL PYSHOW(IQ3,IQ2,PPM)
15031         ENDIF
15032       ENDIF
15033
15034       RETURN
15035       END
15036
15037 C***********************************************************************
15038
15039 *$ CREATE PYKLIM.FOR
15040 *COPY PYKLIM
15041 C...PYKLIM
15042 C...Checks generated variables against pre-set kinematical limits;
15043 C...also calculates limits on variables used in generation.
15044
15045       SUBROUTINE PYKLIM(ILIM)
15046
15047 C...Double precision and integer declarations.
15048       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15049       INTEGER PYK,PYCHGE,PYCOMP
15050 C...Commonblocks.
15051       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15052       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15053       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15054       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15055       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15056       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15057       COMMON/PYINT1/MINT(400),VINT(400)
15058       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15059       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15060      &/PYINT1/,/PYINT2/
15061
15062 C...Common kinematical expressions.
15063       MINT(51)=0
15064       ISUB=MINT(1)
15065       ISTSB=ISET(ISUB)
15066       IF(ISUB.EQ.96) GOTO 100
15067       SQM3=VINT(63)
15068       SQM4=VINT(64)
15069       IF(ILIM.NE.0) THEN
15070         IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
15071           CKIN09=MAX(CKIN(9),CKIN(13))
15072           CKIN10=MIN(CKIN(10),CKIN(14))
15073           CKIN11=MAX(CKIN(11),CKIN(15))
15074           CKIN12=MIN(CKIN(12),CKIN(16))
15075         ELSE
15076           CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
15077           CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
15078           CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
15079           CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
15080         ENDIF
15081       ENDIF
15082       IF(ILIM.NE.1) THEN
15083         TAU=VINT(21)
15084         RM3=SQM3/(TAU*VINT(2))
15085         RM4=SQM4/(TAU*VINT(2))
15086         BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
15087       ENDIF
15088       PTHMIN=CKIN(3)
15089       IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
15090      &PTHMIN=MAX(CKIN(3),CKIN(5))
15091
15092       IF(ILIM.EQ.0) THEN
15093 C...Check generated values of tau, y*, cos(theta-hat), and tau' against
15094 C...pre-set kinematical limits.
15095         YST=VINT(22)
15096         CTH=VINT(23)
15097         TAUP=VINT(26)
15098         TAUE=TAU
15099         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
15100         X1=SQRT(TAUE)*EXP(YST)
15101         X2=SQRT(TAUE)*EXP(-YST)
15102         XF=X1-X2
15103         IF(MINT(47).NE.1) THEN
15104           IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
15105           IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
15106           IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
15107           IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
15108         ENDIF
15109         IF(MINT(45).NE.1) THEN
15110           IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
15111         ENDIF
15112         IF(MINT(46).NE.1) THEN
15113           IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
15114         ENDIF
15115         IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
15116           PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
15117           EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/
15118      &    MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH)))
15119           EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/
15120      &    MAX(1.D-10,(1D0-RM3+RM4+BE34*CTH)))
15121           Y3=YST+0.5D0*LOG(EXPY3)
15122           Y4=YST+0.5D0*LOG(EXPY4)
15123           YLARGE=MAX(Y3,Y4)
15124           YSMALL=MIN(Y3,Y4)
15125           ETALAR=10D0
15126           ETASMA=-10D0
15127           STH=SQRT(MAX(0D0,1D0-CTH**2))
15128           EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
15129      &    CTH)**2-4D0*RM3))
15130           EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
15131      &    CTH)**2-4D0*RM4))
15132           IF(STH.GE.1.D-6) THEN
15133             EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
15134      &      (BE34*STH)
15135             EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
15136      &      (BE34*STH)
15137             ETA3=LOG(MIN(1.D10,MAX(1.D-10,EXPET3)))
15138             ETA4=LOG(MIN(1.D10,MAX(1.D-10,EXPET4)))
15139             ETALAR=MAX(ETA3,ETA4)
15140             ETASMA=MIN(ETA3,ETA4)
15141           ENDIF
15142           CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
15143           CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
15144           CTSLAR=MIN(1D0,MAX(CTS3,CTS4))
15145           CTSSMA=MAX(-1D0,MIN(CTS3,CTS4))
15146           SH=TAU*VINT(2)
15147           RPTS=4D0*VINT(71)**2/SH
15148           BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
15149           RM34=MAX(1D-20,2D0*RM3*RM4)
15150           IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15151      &    RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15152           RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
15153           THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
15154           UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
15155           IF(PTH.LT.PTHMIN) MINT(51)=1
15156           IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
15157           IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
15158           IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
15159           IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
15160           IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
15161           IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
15162           IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
15163           IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
15164           IF(THA.LT.CKIN(35)) MINT(51)=1
15165           IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
15166           IF(UHA.LT.CKIN(37)) MINT(51)=1
15167           IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
15168         ENDIF
15169         IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
15170           IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
15171           IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
15172         ENDIF
15173
15174 C...Additional cuts on W2 (approximately) in DIS.
15175         IF(ISUB.EQ.10) THEN
15176           XBJ=X2
15177           IF(IABS(MINT(12)).LT.20) XBJ=X1
15178           Q2BJ=THA
15179           W2BJ=Q2BJ*(1D0-XBJ)/XBJ
15180           IF(W2BJ.LT.CKIN(39)) MINT(51)=1
15181           IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
15182         ENDIF
15183
15184       ELSEIF(ILIM.EQ.1) THEN
15185 C...Calculate limits on tau
15186 C...0) due to definition
15187         TAUMN0=0D0
15188         TAUMX0=1D0
15189 C...1) due to limits on subsystem mass
15190         TAUMN1=CKIN(1)**2/VINT(2)
15191         TAUMX1=1D0
15192         IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
15193 C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
15194         TM3=SQRT(SQM3+PTHMIN**2)
15195         TM4=SQRT(SQM4+PTHMIN**2)
15196         YDCOSH=1D0
15197         IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
15198         TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
15199         TAUMX2=1D0
15200 C...3) due to limits on pT-hat and cos(theta-hat)
15201         CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
15202         CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
15203         TAUMN3=0D0
15204         IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
15205      &  (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
15206      &  SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
15207         TAUMX3=1D0
15208         IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
15209      &  (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
15210      &  SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
15211 C...4) due to limits on x1 and x2
15212         TAUMN4=CKIN(21)*CKIN(23)
15213         TAUMX4=CKIN(22)*CKIN(24)
15214 C...5) due to limits on xF
15215         TAUMN5=0D0
15216         TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
15217 C...6) due to limits on that and uhat
15218         TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
15219         TAUMX6=1D0
15220         IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
15221      &  (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
15222
15223 C...Net effect of all separate limits.
15224         VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
15225         VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
15226         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15227           VINT(11)=0.99999D0
15228           VINT(31)=1.00001D0
15229         ELSEIF(MINT(47).EQ.5) THEN
15230           VINT(31)=MIN(VINT(31),0.999998D0)
15231         ENDIF
15232         IF(VINT(31).LE.VINT(11)) MINT(51)=1
15233
15234       ELSEIF(ILIM.EQ.2) THEN
15235 C...Calculate limits on y*
15236         TAUE=TAU
15237         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15238         TAURT=SQRT(TAUE)
15239 C...0) due to kinematics
15240         YSTMN0=LOG(TAURT)
15241         YSTMX0=-YSTMN0
15242 C...1) due to explicit limits
15243         YSTMN1=CKIN(7)
15244         YSTMX1=CKIN(8)
15245 C...2) due to limits on x1
15246         YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
15247         YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
15248 C...3) due to limits on x2
15249         YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
15250         YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
15251 C...4) due to limits on xF
15252         YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
15253         YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
15254         YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
15255         YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
15256 C...5) due to simultaneous limits on y-large and y-small
15257         YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
15258         YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
15259         YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
15260         YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
15261         YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
15262         YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
15263 C...6) due to simultaneous limits on cos(theta-hat) and y-large or
15264 C...   y-small
15265         CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
15266         RZMN=BE34*MAX(CKIN(27),-CTHLIM)
15267         RZMX=BE34*MIN(CKIN(28),CTHLIM)
15268         YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
15269         YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
15270         YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
15271         YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
15272         YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
15273         YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
15274
15275 C...Net effect of all separate limits.
15276         VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
15277         VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
15278         IF(MINT(47).EQ.1) THEN
15279           VINT(12)=-0.00001D0
15280           VINT(32)=0.00001D0
15281         ELSEIF(MINT(47).EQ.2) THEN
15282           VINT(12)=0.99999D0*YSTMX0
15283           VINT(32)=1.00001D0*YSTMX0
15284         ELSEIF(MINT(47).EQ.3) THEN
15285           VINT(12)=-1.00001D0*YSTMX0
15286           VINT(32)=-0.99999D0*YSTMX0
15287         ELSEIF(MINT(47).EQ.5) THEN
15288           YSTEE=LOG(0.999999D0/TAURT)
15289           VINT(12)=MAX(VINT(12),-YSTEE)
15290           VINT(32)=MIN(VINT(32),YSTEE)
15291         ENDIF
15292         IF(VINT(32).LE.VINT(12)) MINT(51)=1
15293
15294       ELSEIF(ILIM.EQ.3) THEN
15295 C...Calculate limits on cos(theta-hat)
15296         YST=VINT(22)
15297 C...0) due to definition
15298         CTNMN0=-1D0
15299         CTNMX0=0D0
15300         CTPMN0=0D0
15301         CTPMX0=1D0
15302 C...1) due to explicit limits
15303         CTNMN1=MIN(0D0,CKIN(27))
15304         CTNMX1=MIN(0D0,CKIN(28))
15305         CTPMN1=MAX(0D0,CKIN(27))
15306         CTPMX1=MAX(0D0,CKIN(28))
15307 C...2) due to limits on pT-hat
15308         CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
15309         CTPMX2=-CTNMN2
15310         CTNMX2=0D0
15311         CTPMN2=0D0
15312         IF(CKIN(4).GE.0D0) THEN
15313           CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
15314      &    (BE34**2*TAU*VINT(2))))
15315           CTPMN2=-CTNMX2
15316         ENDIF
15317 C...3) due to limits on y-large and y-small
15318         CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
15319      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
15320         CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
15321      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
15322         CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
15323      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
15324         CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
15325      &  -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
15326 C...4) due to limits on that
15327         CTNMN4=-1D0
15328         CTNMX4=0D0
15329         CTPMN4=0D0
15330         CTPMX4=1D0
15331         SH=TAU*VINT(2)
15332         IF(CKIN(35).GT.0D0) THEN
15333           CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
15334           IF(CTLIM.GT.0D0) THEN
15335             CTPMX4=CTLIM
15336           ELSE
15337             CTPMX4=0D0
15338             CTNMX4=CTLIM
15339           ENDIF
15340         ENDIF
15341         IF(CKIN(36).GT.0D0) THEN
15342           CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
15343           IF(CTLIM.LT.0D0) THEN
15344             CTNMN4=CTLIM
15345           ELSE
15346             CTNMN4=0D0
15347             CTPMN4=CTLIM
15348           ENDIF
15349         ENDIF
15350 C...5) due to limits on uhat
15351         CTNMN5=-1D0
15352         CTNMX5=0D0
15353         CTPMN5=0D0
15354         CTPMX5=1D0
15355         IF(CKIN(37).GT.0D0) THEN
15356           CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
15357           IF(CTLIM.LT.0D0) THEN
15358             CTNMN5=CTLIM
15359           ELSE
15360             CTNMN5=0D0
15361             CTPMN5=CTLIM
15362           ENDIF
15363         ENDIF
15364         IF(CKIN(38).GT.0D0) THEN
15365           CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
15366           IF(CTLIM.GT.0D0) THEN
15367             CTPMX5=CTLIM
15368           ELSE
15369             CTPMX5=0D0
15370             CTNMX5=CTLIM
15371           ENDIF
15372         ENDIF
15373
15374 C...Net effect of all separate limits.
15375         VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
15376         VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
15377         VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
15378         VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
15379         IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
15380
15381       ELSEIF(ILIM.EQ.4) THEN
15382 C...Calculate limits on tau'
15383 C...0) due to kinematics
15384         TAPMN0=TAU
15385         IF(ISTSB.EQ.5.AND.KFPR(ISUB,2).GT.0) THEN
15386           PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/VINT(1)
15387           TAPMN0=(SQRT(TAU)+PQRAT)**2
15388         ENDIF
15389         TAPMX0=1D0
15390 C...1) due to explicit limits
15391         TAPMN1=CKIN(31)**2/VINT(2)
15392         TAPMX1=1D0
15393         IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
15394
15395 C...Net effect of all separate limits.
15396         VINT(16)=MAX(TAPMN0,TAPMN1)
15397         VINT(36)=MIN(TAPMX0,TAPMX1)
15398         IF(MINT(47).EQ.1) THEN
15399           VINT(16)=0.99999D0
15400           VINT(36)=1.00001D0
15401         ENDIF
15402         IF(VINT(36).LE.VINT(16)) MINT(51)=1
15403
15404       ENDIF
15405       RETURN
15406
15407 C...Special case for low-pT and multiple interactions:
15408 C...effective kinematical limits for tau, y*, cos(theta-hat).
15409   100 IF(ILIM.EQ.0) THEN
15410       ELSEIF(ILIM.EQ.1) THEN
15411         IF(MSTP(82).LE.1) VINT(11)=4D0*PARP(81)**2/VINT(2)
15412         IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2)
15413         VINT(31)=1D0
15414       ELSEIF(ILIM.EQ.2) THEN
15415         VINT(12)=0.5D0*LOG(VINT(21))
15416         VINT(32)=-VINT(12)
15417       ELSEIF(ILIM.EQ.3) THEN
15418         IF(MSTP(82).LE.1) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2))
15419         IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2))
15420         VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
15421         VINT(33)=0D0
15422         VINT(14)=0D0
15423         VINT(34)=-VINT(13)
15424       ENDIF
15425
15426       RETURN
15427       END
15428
15429 C*********************************************************************
15430
15431 *$ CREATE PYKMAP.FOR
15432 *COPY PYKMAP
15433 C...PYKMAP
15434 C...Maps a uniform distribution into a distribution of a kinematical
15435 C...variable according to one of the possibilities allowed. It is
15436 C...assumed that kinematical limits have been set by a PYKLIM call.
15437
15438       SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
15439
15440 C...Double precision and integer declarations.
15441       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15442       INTEGER PYK,PYCHGE,PYCOMP
15443 C...Commonblocks.
15444       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15445       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15446       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15447       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15448       COMMON/PYINT1/MINT(400),VINT(400)
15449       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15450       SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
15451
15452 C...Convert VVAR to tau variable.
15453       ISUB=MINT(1)
15454       ISTSB=ISET(ISUB)
15455       IF(IVAR.EQ.1) THEN
15456         TAUMIN=VINT(11)
15457         TAUMAX=VINT(31)
15458         IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
15459           TAURE=VINT(73)
15460           GAMRE=VINT(74)
15461         ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
15462           TAURE=VINT(75)
15463           GAMRE=VINT(76)
15464         ENDIF
15465         IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
15466           TAU=1D0
15467         ELSEIF(MVAR.EQ.1) THEN
15468           TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
15469         ELSEIF(MVAR.EQ.2) THEN
15470           TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
15471         ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
15472           RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
15473           TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
15474         ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
15475           AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
15476           ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
15477           TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
15478         ELSE
15479           AUPP=LOG(MAX(2D-6,1D0-TAUMAX))
15480           ALOW=LOG(MAX(2D-6,1D0-TAUMIN))
15481           TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15482         ENDIF
15483         VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
15484
15485 C...Convert VVAR to y* variable.
15486       ELSEIF(IVAR.EQ.2) THEN
15487         YSTMIN=VINT(12)
15488         YSTMAX=VINT(32)
15489         TAUE=VINT(21)
15490         IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
15491         IF(MINT(47).EQ.1) THEN
15492           YST=0D0
15493         ELSEIF(MINT(47).EQ.2) THEN
15494           YST=-0.5D0*LOG(TAUE)
15495         ELSEIF(MINT(47).EQ.3) THEN
15496           YST=0.5D0*LOG(TAUE)
15497         ELSEIF(MVAR.EQ.1) THEN
15498           YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
15499         ELSEIF(MVAR.EQ.2) THEN
15500           YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
15501         ELSEIF(MVAR.EQ.3) THEN
15502           AUPP=ATAN(EXP(YSTMAX))
15503           ALOW=ATAN(EXP(YSTMIN))
15504           YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
15505         ELSEIF(MVAR.EQ.4) THEN
15506           YST0=-0.5D0*LOG(TAUE)
15507           AUPP=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0))
15508           ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
15509           YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
15510         ELSE
15511           YST0=-0.5D0*LOG(TAUE)
15512           AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
15513           ALOW=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0))
15514           YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
15515         ENDIF
15516         VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
15517
15518 C...Convert VVAR to cos(theta-hat) variable.
15519       ELSEIF(IVAR.EQ.3) THEN
15520         RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
15521         RSQM=1D0+RM34
15522         IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
15523      &  RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
15524         CTNMIN=VINT(13)
15525         CTNMAX=VINT(33)
15526         CTPMIN=VINT(14)
15527         CTPMAX=VINT(34)
15528         IF(MVAR.EQ.1) THEN
15529           ANEG=CTNMAX-CTNMIN
15530           APOS=CTPMAX-CTPMIN
15531           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15532             VCTN=VVAR*(ANEG+APOS)/ANEG
15533             CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
15534           ELSE
15535             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15536             CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
15537           ENDIF
15538         ELSEIF(MVAR.EQ.2) THEN
15539           RMNMIN=MAX(RM34,RSQM-CTNMIN)
15540           RMNMAX=MAX(RM34,RSQM-CTNMAX)
15541           RMPMIN=MAX(RM34,RSQM-CTPMIN)
15542           RMPMAX=MAX(RM34,RSQM-CTPMAX)
15543           ANEG=LOG(RMNMIN/RMNMAX)
15544           APOS=LOG(RMPMIN/RMPMAX)
15545           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15546             VCTN=VVAR*(ANEG+APOS)/ANEG
15547             CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
15548           ELSE
15549             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15550             CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
15551           ENDIF
15552         ELSEIF(MVAR.EQ.3) THEN
15553           RMNMIN=MAX(RM34,RSQM+CTNMIN)
15554           RMNMAX=MAX(RM34,RSQM+CTNMAX)
15555           RMPMIN=MAX(RM34,RSQM+CTPMIN)
15556           RMPMAX=MAX(RM34,RSQM+CTPMAX)
15557           ANEG=LOG(RMNMAX/RMNMIN)
15558           APOS=LOG(RMPMAX/RMPMIN)
15559           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15560             VCTN=VVAR*(ANEG+APOS)/ANEG
15561             CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
15562           ELSE
15563             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15564             CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
15565           ENDIF
15566         ELSEIF(MVAR.EQ.4) THEN
15567           RMNMIN=MAX(RM34,RSQM-CTNMIN)
15568           RMNMAX=MAX(RM34,RSQM-CTNMAX)
15569           RMPMIN=MAX(RM34,RSQM-CTPMIN)
15570           RMPMAX=MAX(RM34,RSQM-CTPMAX)
15571           ANEG=1D0/RMNMAX-1D0/RMNMIN
15572           APOS=1D0/RMPMAX-1D0/RMPMIN
15573           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15574             VCTN=VVAR*(ANEG+APOS)/ANEG
15575             CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
15576           ELSE
15577             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15578             CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
15579           ENDIF
15580         ELSEIF(MVAR.EQ.5) THEN
15581           RMNMIN=MAX(RM34,RSQM+CTNMIN)
15582           RMNMAX=MAX(RM34,RSQM+CTNMAX)
15583           RMPMIN=MAX(RM34,RSQM+CTPMIN)
15584           RMPMAX=MAX(RM34,RSQM+CTPMAX)
15585           ANEG=1D0/RMNMIN-1D0/RMNMAX
15586           APOS=1D0/RMPMIN-1D0/RMPMAX
15587           IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
15588             VCTN=VVAR*(ANEG+APOS)/ANEG
15589             CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
15590           ELSE
15591             VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
15592             CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
15593           ENDIF
15594         ENDIF
15595         IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
15596         IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
15597         VINT(23)=CTH
15598
15599 C...Convert VVAR to tau' variable.
15600       ELSEIF(IVAR.EQ.4) THEN
15601         TAU=VINT(21)
15602         TAUPMN=VINT(16)
15603         TAUPMX=VINT(36)
15604         IF(MINT(47).EQ.1) THEN
15605           TAUP=1D0
15606         ELSEIF(MVAR.EQ.1) THEN
15607           TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
15608         ELSEIF(MVAR.EQ.2) THEN
15609           AUPP=(1D0-TAU/TAUPMX)**4
15610           ALOW=(1D0-TAU/TAUPMN)**4
15611           TAUP=TAU/MAX(1D-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
15612         ELSE
15613           AUPP=LOG(MAX(2D-6,1D0-TAUPMX))
15614           ALOW=LOG(MAX(2D-6,1D0-TAUPMN))
15615           TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
15616         ENDIF
15617         VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
15618
15619 C...Selection of extra variables needed in 2 -> 3 process:
15620 C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
15621 C...Since no options are available, the functions of PYKLIM
15622 C...and PYKMAP are joint for these choices.
15623       ELSEIF(IVAR.EQ.5) THEN
15624
15625 C...Read out total energy and particle masses.
15626         MINT(51)=0
15627         MPTPK=1
15628         IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
15629      &  .OR.ISUB.EQ.178.OR.ISUB.EQ.179) MPTPK=2
15630         SHP=VINT(26)*VINT(2)
15631         SHPR=SQRT(SHP)
15632         PM1=VINT(201)
15633         PM2=VINT(206)
15634         PM3=SQRT(VINT(21))*VINT(1)
15635         IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
15636           MINT(51)=1
15637           RETURN
15638         ENDIF
15639         PMRS1=VINT(204)**2
15640         PMRS2=VINT(209)**2
15641
15642 C...Specify coefficients of pT choice; upper and lower limits.
15643         IF(MPTPK.EQ.1) THEN
15644           HWT1=0.4D0
15645           HWT2=0.4D0
15646         ELSE
15647           HWT1=0.05D0
15648           HWT2=0.05D0
15649         ENDIF
15650         HWT3=1D0-HWT1-HWT2
15651         PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
15652      &  (4D0*SHP)
15653         IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
15654         PTSMN1=CKIN(51)**2
15655         PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
15656      &  (4D0*SHP)
15657         IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
15658         PTSMN2=CKIN(53)**2
15659
15660 C...Select transverse momenta according to
15661 C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
15662         HMX=PMRS1+PTSMX1
15663         HMN=PMRS1+PTSMN1
15664         IF(HMX.LT.1.0001D0*HMN) THEN
15665           MINT(51)=1
15666           RETURN
15667         ENDIF
15668         HDE=PTSMX1-PTSMN1
15669         RPT=PYR(0)
15670         IF(RPT.LT.HWT1) THEN
15671           PTS1=PTSMN1+PYR(0)*HDE
15672         ELSEIF(RPT.LT.HWT1+HWT2) THEN
15673           PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
15674         ELSE
15675           PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
15676         ENDIF
15677         WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
15678      &  HWT3*HMN*HMX/(PMRS1+PTS1)**2)
15679         HMX=PMRS2+PTSMX2
15680         HMN=PMRS2+PTSMN2
15681         IF(HMX.LT.1.0001D0*HMN) THEN
15682           MINT(51)=1
15683           RETURN
15684         ENDIF
15685         HDE=PTSMX2-PTSMN2
15686         RPT=PYR(0)
15687         IF(RPT.LT.HWT1) THEN
15688           PTS2=PTSMN2+PYR(0)*HDE
15689         ELSEIF(RPT.LT.HWT1+HWT2) THEN
15690           PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
15691         ELSE
15692           PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
15693         ENDIF
15694         WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
15695      &  HWT3*HMN*HMX/(PMRS2+PTS2)**2)
15696
15697 C...Select azimuthal angles and check pT choice.
15698         PHI1=PARU(2)*PYR(0)
15699         PHI2=PARU(2)*PYR(0)
15700         PHIR=PHI2-PHI1
15701         PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
15702         IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
15703      &  CKIN(56)**2)) THEN
15704           MINT(51)=1
15705           RETURN
15706         ENDIF
15707
15708 C...Calculate transverse masses and check phase space not closed.
15709         PMS1=PM1**2+PTS1
15710         PMS2=PM2**2+PTS2
15711         PMS3=PM3**2+PTS3
15712         PMT1=SQRT(PMS1)
15713         PMT2=SQRT(PMS2)
15714         PMT3=SQRT(PMS3)
15715         PM12=(PMT1+PMT2)**2
15716         IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
15717           MINT(51)=1
15718           RETURN
15719         ENDIF
15720
15721 C...Select rapidity for particle 3 and check phase space not closed.
15722         Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
15723      &  4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
15724         IF(Y3MAX.LT.1D-6) THEN
15725           MINT(51)=1
15726           RETURN
15727         ENDIF
15728         Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
15729         PZ3=PMT3*SINH(Y3)
15730         PE3=PMT3*COSH(Y3)
15731
15732 C...Find momentum transfers in two mirror solutions (in 1-2 frame).
15733         PZ12=-PZ3
15734         PE12=SHPR-PE3
15735         PMS12=PE12**2-PZ12**2
15736         SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
15737         IF(SQL12.LT.1D-6*SHP) THEN
15738           MINT(51)=1
15739           RETURN
15740         ENDIF
15741         PMM1=PMS12+PMS1-PMS2
15742         PMM2=PMS12+PMS2-PMS1
15743         TFAC=-SHPR/(2D0*PMS12)
15744         T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
15745         T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
15746         T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
15747         T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
15748
15749 C...Construct relative mirror weights and make choice.
15750         IF(MPTPK.EQ.1) THEN
15751           WTPU=1D0
15752           WTNU=1D0
15753         ELSE
15754           WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
15755           WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
15756         ENDIF
15757         WTP=WTPU/(WTPU+WTNU)
15758         WTN=WTNU/(WTPU+WTNU)
15759         EPS=1D0
15760         IF(WTN.GT.PYR(0)) EPS=-1D0
15761
15762 C...Store result of variable choice and associated weights.
15763         VINT(202)=PTS1
15764         VINT(207)=PTS2
15765         VINT(203)=PHI1
15766         VINT(208)=PHI2
15767         VINT(205)=WTPTS1
15768         VINT(210)=WTPTS2
15769         VINT(211)=Y3
15770         VINT(212)=Y3MAX
15771         VINT(213)=EPS
15772         IF(EPS.GT.0D0) THEN
15773           VINT(214)=1D0/WTP
15774           VINT(215)=T1P
15775           VINT(216)=T2P
15776         ELSE
15777           VINT(214)=1D0/WTN
15778           VINT(215)=T1N
15779           VINT(216)=T2N
15780         ENDIF
15781         VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
15782         VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
15783         VINT(219)=0.5D0*(PMS12-PTS3)
15784         VINT(220)=SQL12
15785       ENDIF
15786
15787       RETURN
15788       END
15789
15790 C***********************************************************************
15791
15792 *$ CREATE PYSIGH.FOR
15793 *COPY PYSIGH
15794 C...PYSIGH
15795 C...Differential matrix elements for all included subprocesses
15796 C...Note that what is coded is (disregarding the COMFAC factor)
15797 C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
15798 C...when d(sigma-hat) is given in the zero-width limit, the delta
15799 C...function in tau is replaced by a (modified) Breit-Wigner:
15800 C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
15801 C...where H_res = s-hat/m_res*Gamma_res(s-hat);
15802 C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
15803 C...i.e., dimensionless quantities
15804 C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
15805 C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
15806 C...(2pi)^4 delta^4(P - sum p_i)
15807 C...COMFAC contains the factor pi/s (or equivalent) and
15808 C...the conversion factor from GeV^-2 to mb
15809
15810       SUBROUTINE PYSIGH(NCHN,SIGS)
15811
15812 C...Double precision and integer declarations
15813       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15814       INTEGER PYK,PYCHGE,PYCOMP
15815 C...Parameter statement to help give large particle numbers.
15816       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
15817 C...Commonblocks
15818       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15819       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15820       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15821       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
15822       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15823       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15824       COMMON/PYINT1/MINT(400),VINT(400)
15825       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15826       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15827       COMMON/PYINT4/MWID(500),WIDS(500,5)
15828       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15829       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15830       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
15831      &SFMIX(16,4)
15832       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
15833      &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
15834      &/PYSSMT/
15835 C...Local arrays and complex variables
15836       DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200),
15837      &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3)
15838       COMPLEX A004,A204,A114,A00U,A20U,A11U
15839       COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF,
15840      &COULCK,COULCP,COULCD,COULCR,COULCS
15841       REAL A00L,A11L,A20L,COULXX
15842
15843 C...Reset number of channels and cross-section
15844       NCHN=0
15845       SIGS=0D0
15846
15847 C...Convert H or A process into equivalent h one
15848       ISUB=MINT(1)
15849       ISUBSV=ISUB
15850       IHIGG=1
15851       KFHIGG=25
15852       IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
15853      &ISUB.LE.190)) THEN
15854         IHIGG=2
15855         IF(MOD(ISUB-1,10).GE.5) IHIGG=3
15856         KFHIGG=33+IHIGG
15857         IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
15858         IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
15859         IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
15860         IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
15861         IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
15862         IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
15863         IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
15864         IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
15865         IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
15866       ENDIF
15867
15868 CMRENNA++
15869 C...Convert almost equivalent SUSY processes into each other
15870 C...Extract differences in flavours and couplings
15871       IF(ISUB.GE.200.AND.ISUB.LE.280) THEN
15872
15873 C...Sleptons and sneutrinos
15874         IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
15875           KFID=MOD(KFPR(ISUB,1),KSUSY1)
15876           ISUB=201
15877           ILR=0
15878         ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
15879           KFID=MOD(KFPR(ISUB,1),KSUSY1)
15880           ISUB=201
15881           ILR=1
15882         ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
15883           KFID=MOD(KFPR(ISUB,1),KSUSY1)
15884           ISUB=203
15885         ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
15886           IF(ISUB.EQ.210) THEN
15887             RKF=2.0D0
15888           ELSEIF(ISUB.EQ.211) THEN
15889             RKF=SFMIX(15,1)**2
15890           ELSEIF(ISUB.EQ.212) THEN
15891             RKF=SFMIX(15,2)**2
15892           ENDIF
15893           ISUB=210
15894         ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
15895           IF(ISUB.EQ.213) THEN
15896             KFID=MOD(KFPR(ISUB,1),KSUSY1)
15897             RKF=2.0D0
15898           ELSEIF(ISUB.EQ.214) THEN
15899             KFID=16
15900             RKF=1.0D0
15901           ENDIF
15902           ISUB=213
15903
15904 C...Neutralinos
15905         ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
15906           IF(ISUB.EQ.216) THEN
15907             IZID1=1
15908             IZID2=1
15909           ELSEIF(ISUB.EQ.217) THEN
15910             IZID1=2
15911             IZID2=2
15912           ELSEIF(ISUB.EQ.218) THEN
15913             IZID1=3
15914             IZID2=3
15915           ELSEIF(ISUB.EQ.219) THEN
15916             IZID1=4
15917             IZID2=4
15918           ELSEIF(ISUB.EQ.220) THEN
15919             IZID1=1
15920             IZID2=2
15921           ELSEIF(ISUB.EQ.221) THEN
15922             IZID1=1
15923             IZID2=3
15924           ELSEIF(ISUB.EQ.222) THEN
15925             IZID1=1
15926             IZID2=4
15927           ELSEIF(ISUB.EQ.223) THEN
15928             IZID1=2
15929             IZID2=3
15930           ELSEIF(ISUB.EQ.224) THEN
15931             IZID1=2
15932             IZID2=4
15933           ELSEIF(ISUB.EQ.225) THEN
15934             IZID1=3
15935             IZID2=4
15936           ENDIF
15937           ISUB=216
15938
15939 C...Charginos
15940         ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
15941           IF(ISUB.EQ.226) THEN
15942             IZID1=1
15943             IZID2=1
15944           ELSEIF(ISUB.EQ.227) THEN
15945             IZID1=2
15946             IZID2=2
15947           ELSEIF(ISUB.EQ.228) THEN
15948             IZID1=1
15949             IZID2=2
15950           ENDIF
15951           ISUB=226
15952
15953 C...Neutralino + chargino
15954         ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
15955           IF(ISUB.EQ.229) THEN
15956             IZID1=1
15957             IZID2=1
15958           ELSEIF(ISUB.EQ.230) THEN
15959             IZID1=1
15960             IZID2=2
15961           ELSEIF(ISUB.EQ.231) THEN
15962             IZID1=1
15963             IZID2=3
15964           ELSEIF(ISUB.EQ.232) THEN
15965             IZID1=1
15966             IZID2=4
15967           ELSEIF(ISUB.EQ.233) THEN
15968             IZID1=2
15969             IZID2=1
15970           ELSEIF(ISUB.EQ.234) THEN
15971             IZID1=2
15972             IZID2=2
15973           ELSEIF(ISUB.EQ.235) THEN
15974             IZID1=2
15975             IZID2=3
15976           ELSEIF(ISUB.EQ.236) THEN
15977             IZID1=2
15978             IZID2=4
15979           ENDIF
15980           ISUB=229
15981
15982 C...Gluino + neutralino
15983         ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
15984           IF(ISUB.EQ.237) THEN
15985             IZID=1
15986           ELSEIF(ISUB.EQ.238) THEN
15987             IZID=2
15988           ELSEIF(ISUB.EQ.239) THEN
15989             IZID=3
15990           ELSEIF(ISUB.EQ.240) THEN
15991             IZID=4
15992           ENDIF
15993           ISUB=237
15994
15995 C...Gluino + chargino
15996         ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
15997           IF(ISUB.EQ.241) THEN
15998             IZID=1
15999           ELSEIF(ISUB.EQ.242) THEN
16000             IZID=2
16001           ENDIF
16002           ISUB=241
16003
16004 C...Squark + neutralino
16005         ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
16006           ILR=0
16007           IF(MOD(ISUB,2).NE.0) ILR=1
16008           IF(ISUB.LE.247) THEN
16009             IZID=1
16010           ELSEIF(ISUB.LE.249) THEN
16011             IZID=2
16012           ELSEIF(ISUB.LE.251) THEN
16013             IZID=3
16014           ELSEIF(ISUB.LE.253) THEN
16015             IZID=4
16016           ENDIF
16017           ISUB=246
16018           RKF=5D0
16019
16020 C...Squark + chargino
16021         ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
16022           IF(ISUB.LE.255) THEN
16023             IZID=1
16024           ELSEIF(ISUB.LE.257) THEN
16025             IZID=2
16026           ENDIF
16027           IF(MOD(ISUB,2).EQ.0) THEN
16028             ILR=0
16029           ELSE
16030             ILR=1
16031           ENDIF
16032           ISUB=254
16033           RKF=5D0
16034
16035 C...Squark + gluino
16036         ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
16037           ISUB=258
16038           RKF=5D0
16039
16040 C...Stops
16041         ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
16042           ILR=0
16043           IF(ISUB.EQ.262) ILR=1
16044           ISUB=261
16045         ELSEIF(ISUB.EQ.265) THEN
16046           ISUB=264
16047
16048 C...Squarks
16049         ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
16050           ILR=0
16051           IF(ISUB.LE.273) THEN
16052             IF(ISUB.EQ.273) ILR=1
16053             ISUB=271
16054             RKF=25D0
16055           ELSEIF(ISUB.LE.276) THEN
16056             IF(ISUB.EQ.276) ILR=1
16057             ISUB=274
16058             RKF=25D0
16059           ELSEIF(ISUB.LE.278) THEN
16060             IF(ISUB.EQ.278) ILR=1
16061             ISUB=277
16062             RKF=5D0
16063           ELSE
16064             IF(ISUB.EQ.280) ILR=1
16065             ISUB=279
16066             RKF=5D0
16067           ENDIF
16068         ENDIF
16069       ENDIF
16070 CMRENNA--
16071
16072 C...Read kinematical variables and limits
16073       ISTSB=ISET(ISUBSV)
16074       TAUMIN=VINT(11)
16075       YSTMIN=VINT(12)
16076       CTNMIN=VINT(13)
16077       CTPMIN=VINT(14)
16078       TAUPMN=VINT(16)
16079       TAU=VINT(21)
16080       YST=VINT(22)
16081       CTH=VINT(23)
16082       XT2=VINT(25)
16083       TAUP=VINT(26)
16084       TAUMAX=VINT(31)
16085       YSTMAX=VINT(32)
16086       CTNMAX=VINT(33)
16087       CTPMAX=VINT(34)
16088       TAUPMX=VINT(36)
16089
16090 C...Derive kinematical quantities
16091       TAUE=TAU
16092       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
16093       X(1)=SQRT(TAUE)*EXP(YST)
16094       X(2)=SQRT(TAUE)*EXP(-YST)
16095       IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
16096         IF(X(1).GT.0.9999D0) RETURN
16097       ELSEIF(MINT(45).EQ.3) THEN
16098         X(1)=MIN(0.9999989D0,X(1))
16099       ENDIF
16100       IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
16101         IF(X(2).GT.0.9999D0) RETURN
16102       ELSEIF(MINT(46).EQ.3) THEN
16103         X(2)=MIN(0.9999989D0,X(2))
16104       ENDIF
16105       SH=TAU*VINT(2)
16106       SQM3=VINT(63)
16107       SQM4=VINT(64)
16108       RM3=SQM3/SH
16109       RM4=SQM4/SH
16110       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
16111       RPTS=4D0*VINT(71)**2/SH
16112       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
16113       RM34=MAX(1D-20,2D0*RM3*RM4)
16114       RSQM=1D0+RM34
16115       IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) RM34=MAX(RM34,
16116      &2D0*VINT(71)**2/(VINT(21)*VINT(2)))
16117       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
16118       IF(ISTSB.EQ.0) THEN
16119         TH=VINT(45)
16120         UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16121         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
16122       ELSE
16123         TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
16124         UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
16125         SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
16126       ENDIF
16127       SHR=SQRT(SH)
16128       SH2=SH**2
16129       TH2=TH**2
16130       UH2=UH**2
16131
16132 C...Choice of Q2 scale: hard, parton distributions, parton showers
16133       IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
16134         Q2=SH
16135       ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
16136         IF(MSTP(32).EQ.1) THEN
16137           Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
16138         ELSEIF(MSTP(32).EQ.2) THEN
16139           Q2=SQPTH+0.5D0*(SQM3+SQM4)
16140         ELSEIF(MSTP(32).EQ.3) THEN
16141           Q2=MIN(-TH,-UH)
16142         ELSEIF(MSTP(32).EQ.4) THEN
16143           Q2=SH
16144         ELSEIF(MSTP(32).EQ.5) THEN
16145           Q2=-TH
16146         ENDIF
16147         IF(ISTSB.EQ.9) Q2=SQPTH
16148         IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND.
16149      &  MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2
16150       ENDIF
16151       Q2SF=Q2
16152       IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16153         Q2SF=PMAS(23,1)**2
16154         IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124)
16155      &  Q2SF=PMAS(24,1)**2
16156         IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN
16157           Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
16158           IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207))
16159           IF(MSTP(39).EQ.3) Q2SF=SH
16160           IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
16161         ENDIF
16162       ENDIF
16163       Q2PS=Q2SF
16164       Q2SF=Q2SF*PARP(34)
16165       IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2)
16166       IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
16167      &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
16168         XBJ=X(2)
16169         IF(MINT(43).EQ.3) XBJ=X(1)
16170         IF(MSTP(22).EQ.1) THEN
16171           Q2PS=-TH
16172         ELSEIF(MSTP(22).EQ.2) THEN
16173           Q2PS=((1D0-XBJ)/XBJ)*(-TH)
16174         ELSEIF(MSTP(22).EQ.3) THEN
16175           Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
16176         ELSE
16177           Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
16178         ENDIF
16179       ENDIF
16180       IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2)
16181
16182 C...Store derived kinematical quantities
16183       VINT(41)=X(1)
16184       VINT(42)=X(2)
16185       VINT(44)=SH
16186       VINT(43)=SQRT(SH)
16187       VINT(45)=TH
16188       VINT(46)=UH
16189       VINT(48)=SQPTH
16190       VINT(47)=SQRT(SQPTH)
16191       VINT(50)=TAUP*VINT(2)
16192       VINT(49)=SQRT(MAX(0D0,VINT(50)))
16193       VINT(52)=Q2
16194       VINT(51)=SQRT(Q2)
16195       VINT(54)=Q2SF
16196       VINT(53)=SQRT(Q2SF)
16197       VINT(56)=Q2PS
16198       VINT(55)=SQRT(Q2PS)
16199
16200 C...Calculate parton distributions
16201       IF(ISTSB.LE.0) GOTO 170
16202       IF(MINT(47).GE.2) THEN
16203         DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
16204           XSF=X(I)
16205           IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
16206           MINT(105)=MINT(102+I)
16207           MINT(109)=MINT(106+I)
16208           IF(MSTP(57).LE.1) THEN
16209             CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
16210           ELSE
16211             CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
16212           ENDIF
16213           DO 100 KFL=-25,25
16214             XSFX(I,KFL)=XPQ(KFL)
16215   100     CONTINUE
16216   110   CONTINUE
16217       ENDIF
16218
16219 C...Calculate alpha_em, alpha_strong and K-factor
16220       XW=PARU(102)
16221       XWV=XW
16222       IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
16223      &1D0-(PMAS(24,1)/PMAS(23,1))**2
16224       XW1=1D0-XW
16225       XWC=1D0/(16D0*XW*XW1)
16226       AEM=PYALEM(Q2)
16227       IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
16228       IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
16229       FACK=1D0
16230       FACA=1D0
16231       IF(MSTP(33).EQ.1) THEN
16232         FACK=PARP(31)
16233       ELSEIF(MSTP(33).EQ.2) THEN
16234         FACK=PARP(31)
16235         FACA=PARP(32)/PARP(31)
16236       ELSEIF(MSTP(33).EQ.3) THEN
16237         Q2AS=PARP(33)*Q2
16238         IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
16239      &  PARU(112)*PARP(82)
16240         AS=PYALPS(Q2AS)
16241       ENDIF
16242       VINT(138)=1D0
16243       VINT(57)=AEM
16244       VINT(58)=AS
16245
16246 C...Set flags for allowed reacting partons/leptons
16247       DO 140 I=1,2
16248         DO 120 J=-25,25
16249           KFAC(I,J)=0
16250   120   CONTINUE
16251         IF(MINT(44+I).EQ.1) THEN
16252           KFAC(I,MINT(10+I))=1
16253         ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
16254           KFAC(I,MINT(10+I))=1
16255           KFAC(I,22)=1
16256           KFAC(I,24)=1
16257           KFAC(I,-24)=1
16258         ELSE
16259           DO 130 J=-25,25
16260             KFAC(I,J)=KFIN(I,J)
16261             IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
16262             IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
16263   130     CONTINUE
16264         ENDIF
16265   140 CONTINUE
16266
16267 C...Lower and upper limit for fermion flavour loops
16268       MMIN1=0
16269       MMAX1=0
16270       MMIN2=0
16271       MMAX2=0
16272       DO 150 J=-20,20
16273         IF(KFAC(1,-J).EQ.1) MMIN1=-J
16274         IF(KFAC(1,J).EQ.1) MMAX1=J
16275         IF(KFAC(2,-J).EQ.1) MMIN2=-J
16276         IF(KFAC(2,J).EQ.1) MMAX2=J
16277   150 CONTINUE
16278       MMINA=MIN(MMIN1,MMIN2)
16279       MMAXA=MAX(MMAX1,MMAX2)
16280
16281 C...Common resonance mass and width combinations
16282       SQMZ=PMAS(23,1)**2
16283       SQMW=PMAS(24,1)**2
16284       SQMH=PMAS(KFHIGG,1)**2
16285       GMMZ=PMAS(23,1)*PMAS(23,2)
16286       GMMW=PMAS(24,1)*PMAS(24,2)
16287       GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
16288 C...MRENNA+++
16289       ZWID=PMAS(23,2)
16290       WWID=PMAS(24,2)
16291       TANW=SQRT(XW/XW1)
16292 C...MRENNA---
16293
16294 C...Phase space integral in tau
16295       COMFAC=PARU(1)*PARU(5)/VINT(2)
16296       IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
16297       IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
16298      &ISTSB.NE.9) THEN
16299         ATAU1=LOG(TAUMAX/TAUMIN)
16300         ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
16301         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
16302         IF(MINT(72).GE.1) THEN
16303           TAUR1=VINT(73)
16304           GAMR1=VINT(74)
16305           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
16306           ATAU3=ATAUD/TAUR1
16307           IF(ATAUD.GT.1D-6) H1=H1+
16308      &    (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
16309           ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
16310           ATAU4=ATAUD/GAMR1
16311           IF(ATAUD.GT.1D-6) H1=H1+
16312      &    (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
16313         ENDIF
16314         IF(MINT(72).EQ.2) THEN
16315           TAUR2=VINT(75)
16316           GAMR2=VINT(76)
16317           ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
16318           ATAU5=ATAUD/TAUR2
16319           IF(ATAUD.GT.1D-6) H1=H1+
16320      &    (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
16321           ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
16322           ATAU6=ATAUD/GAMR2
16323           IF(ATAUD.GT.1D-6) H1=H1+
16324      &    (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
16325         ENDIF
16326         IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
16327           ATAU7=LOG(MAX(2D-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX))
16328           IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
16329      &    MAX(2D-6,1D0-TAU)
16330         ENDIF
16331         COMFAC=COMFAC*ATAU1/(TAU*H1)
16332       ENDIF
16333
16334 C...Phase space integral in y*
16335       IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN
16336         AYST0=YSTMAX-YSTMIN
16337         IF(AYST0.LT.1D-6) THEN
16338           COMFAC=0D0
16339         ELSE
16340           AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16341           AYST2=AYST1
16342           AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16343           H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16344      &    (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16345      &    (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16346           IF(MINT(45).EQ.3) THEN
16347             YST0=-0.5D0*LOG(TAUE)
16348             AYST4=LOG(MAX(1D-6,EXP(YST0-YSTMIN)-1D0)/
16349      &      MAX(1D-6,EXP(YST0-YSTMAX)-1D0))
16350             IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
16351      &      MAX(1D-6,1D0-EXP(YST-YST0))
16352           ENDIF
16353           IF(MINT(46).EQ.3) THEN
16354             YST0=-0.5D0*LOG(TAUE)
16355             AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/
16356      &      MAX(1D-6,EXP(YST0+YSTMIN)-1D0))
16357             IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
16358      &      MAX(1D-6,1D0-EXP(-YST-YST0))
16359           ENDIF
16360           COMFAC=COMFAC*AYST0/H2
16361         ENDIF
16362       ENDIF
16363
16364 C...2 -> 1 processes: reduction in angular part of phase space integral
16365 C...for case of decaying resonance
16366       ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
16367       IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
16368         IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
16369           IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
16370      &    KFPR(ISUB,1).EQ.39) THEN
16371             COMFAC=COMFAC*0.5D0*ACTH0
16372           ELSE
16373             COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
16374      &      CTPMAX**3-CTPMIN**3)
16375           ENDIF
16376         ENDIF
16377
16378 C...2 -> 2 processes: angular part of phase space integral
16379       ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
16380         ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
16381      &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
16382         ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
16383      &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
16384         ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
16385      &  1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
16386         ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
16387      &  1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
16388         H3=COEF(ISUBSV,13)+
16389      &  (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
16390      &  (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
16391      &  (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
16392      &  (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
16393         COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
16394
16395 C...2 -> 2 processes: take into account final state Breit-Wigners
16396         COMFAC=COMFAC*VINT(80)
16397       ENDIF
16398
16399 C...2 -> 3, 4 processes: phace space integral in tau'
16400       IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
16401         ATAUP1=LOG(TAUPMX/TAUPMN)
16402         ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
16403         H4=COEF(ISUBSV,18)+
16404      &  (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
16405         IF(MINT(47).EQ.5) THEN
16406           ATAUP3=LOG(MAX(2D-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX))
16407           H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,1D0-TAUP)
16408         ENDIF
16409         COMFAC=COMFAC*ATAUP1/H4
16410       ENDIF
16411
16412 C...2 -> 3, 4 processes: effective W/Z parton distributions
16413       IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
16414         IF(1D0-TAU/TAUP.GT.1.D-4) THEN
16415           FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
16416         ELSE
16417           FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
16418         ENDIF
16419         COMFAC=COMFAC*FZW
16420       ENDIF
16421
16422 C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
16423       IF(ISTSB.EQ.5) THEN
16424         COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
16425      &  (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
16426       ENDIF
16427
16428 C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2
16429       IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC*
16430      &SQPTH**2/(PARP(82)**2+SQPTH)**2
16431
16432 C...gamma + gamma: include factor 2 when different nature
16433       IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4)
16434      &COMFAC=2D0*COMFAC
16435
16436 C...Phase space integral for low-pT and multiple interactions
16437       IF(ISTSB.EQ.9) THEN
16438         COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
16439         ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
16440         ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
16441         H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
16442         COMFAC=COMFAC*ATAU1/H1
16443         AYST0=YSTMAX-YSTMIN
16444         AYST1=0.5D0*(YSTMAX-YSTMIN)**2
16445         AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
16446         H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
16447      &  (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
16448      &  (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
16449         COMFAC=COMFAC*AYST0/H2
16450         IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
16451 C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
16452 C...introduced to make cross-section finite for xT2 -> 0
16453         IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
16454      &  (1D0+VINT(149)))
16455       ENDIF
16456
16457 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
16458       IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
16459      &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
16460 C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
16461         IF(MSTP(46).LE.4) THEN
16462           HDTLH=LOG(PMAS(25,1)/PARP(44))
16463           HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
16464           HDTNR=-1D0/18D0+HDTLH/6D0
16465         ELSE
16466           HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
16467           HDTLQ=LOG(PARP(45)/PARP(44))
16468           HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
16469           HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
16470         ENDIF
16471
16472 C...Calculate lowest and next-to-lowest order partial wave amplitudes
16473         HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
16474         A00L=SNGL(HDTV*SH)
16475         A20L=-0.5*A00L
16476         A11L=A00L/6.
16477         HDTLS=LOG(SH/PARP(44)**2)
16478         A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16479      &  CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
16480      &  (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1)))
16481         A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))*
16482      &  CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
16483      &  (20D0/9D0)*HDTLS),SNGL(PARU(1)))
16484         A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))*
16485      &  CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0))
16486
16487 C...Unitarize partial wave amplitudes with Pade or K-matrix method
16488         IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
16489           A00U=A00L/(1.-A004/A00L)
16490           A20U=A20L/(1.-A204/A20L)
16491           A11U=A11L/(1.-A114/A11L)
16492         ELSE
16493           A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004)))
16494           A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204)))
16495           A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114)))
16496         ENDIF
16497       ENDIF
16498
16499 C...Supersymmetric processes - all of type 2 -> 2 :
16500 C...correct final-state Breit-Wigners from fixed to running width.
16501       IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN
16502         DO 160 I=1,2
16503         KFLW=KFPR(ISUBSV,I)
16504         KCW=PYCOMP(KFLW)
16505         IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160
16506         IF(I.EQ.1) SQMI=SQM3
16507         IF(I.EQ.2) SQMI=SQM4
16508         SQMS=PMAS(KCW,1)**2
16509         GMMS=PMAS(KCW,1)*PMAS(KCW,2)
16510         HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
16511         CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
16512         GMMI=SQRT(SQMI)*WDTP(0)
16513         HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
16514         COMFAC=COMFAC*(HBWI/HBWS)
16515   160   CONTINUE
16516       ENDIF
16517
16518 C...A: 2 -> 1, tree diagrams
16519
16520   170 IF(ISUB.LE.10) THEN
16521         IF(ISUB.EQ.1) THEN
16522 C...f + fbar -> gamma*/Z0
16523           MINT(61)=2
16524           CALL PYWIDT(23,SH,WDTP,WDTE)
16525           HS=SHR*WDTP(0)
16526           FACZ=4D0*COMFAC*3D0
16527           HP0=AEM/3D0*SH
16528           HP1=AEM/3D0*XWC*SH
16529           DO 180 I=MMINA,MMAXA
16530             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
16531             EI=KCHG(IABS(I),1)/3D0
16532             AI=SIGN(1D0,EI)
16533             VI=AI-4D0*EI*XWV
16534             HI0=HP0
16535             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
16536             HI1=HP1
16537             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
16538             NCHN=NCHN+1
16539             ISIG(NCHN,1)=I
16540             ISIG(NCHN,2)=-I
16541             ISIG(NCHN,3)=1
16542             SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
16543      &      EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
16544      &      (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
16545      &      ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
16546   180     CONTINUE
16547
16548         ELSEIF(ISUB.EQ.2) THEN
16549 C...f + fbar' -> W+/-
16550           CALL PYWIDT(24,SH,WDTP,WDTE)
16551           HS=SHR*WDTP(0)
16552           FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
16553           HP=AEM/(24D0*XW)*SH
16554           DO 200 I=MMIN1,MMAX1
16555             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200
16556             IA=IABS(I)
16557             DO 190 J=MMIN2,MMAX2
16558               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190
16559               JA=IABS(J)
16560               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
16561               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
16562      &        GOTO 190
16563               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16564               HI=HP*2D0
16565               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
16566               NCHN=NCHN+1
16567               ISIG(NCHN,1)=I
16568               ISIG(NCHN,2)=J
16569               ISIG(NCHN,3)=1
16570               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
16571               SIGH(NCHN)=HI*FACBW*HF
16572   190       CONTINUE
16573   200     CONTINUE
16574
16575         ELSEIF(ISUB.EQ.3) THEN
16576 C...f + fbar -> h0 (or H0, or A0)
16577           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
16578           HS=SHR*WDTP(0)
16579           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16580           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
16581      &    FACBW=0D0
16582           HP=AEM/(8D0*XW)*SH/SQMW*SH
16583           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16584           DO 210 I=MMINA,MMAXA
16585             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
16586             IA=IABS(I)
16587             RMQ=PMAS(IA,1)**2/SH
16588             HI=HP*RMQ
16589             IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
16590             IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI*
16591      &      (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/
16592      &      LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
16593             IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
16594               IKFI=1
16595               IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
16596               IF(IA.GT.10) IKFI=3
16597               HI=HI*PARU(150+10*IHIGG+IKFI)**2
16598             ENDIF
16599             NCHN=NCHN+1
16600             ISIG(NCHN,1)=I
16601             ISIG(NCHN,2)=-I
16602             ISIG(NCHN,3)=1
16603             SIGH(NCHN)=HI*FACBW*HF
16604   210     CONTINUE
16605
16606         ELSEIF(ISUB.EQ.4) THEN
16607 C...gamma + W+/- -> W+/-
16608
16609         ELSEIF(ISUB.EQ.5) THEN
16610 C...Z0 + Z0 -> h0
16611           CALL PYWIDT(25,SH,WDTP,WDTE)
16612           HS=SHR*WDTP(0)
16613           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16614           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16615           HP=AEM/(8D0*XW)*SH/SQMW*SH
16616           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16617           HI=HP/4D0
16618           FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
16619           DO 230 I=MMIN1,MMAX1
16620             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230
16621             DO 220 J=MMIN2,MMAX2
16622               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220
16623               EI=KCHG(IABS(I),1)/3D0
16624               AI=SIGN(1D0,EI)
16625               VI=AI-4D0*EI*XWV
16626               EJ=KCHG(IABS(J),1)/3D0
16627               AJ=SIGN(1D0,EJ)
16628               VJ=AJ-4D0*EJ*XWV
16629               NCHN=NCHN+1
16630               ISIG(NCHN,1)=I
16631               ISIG(NCHN,2)=J
16632               ISIG(NCHN,3)=1
16633               SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
16634   220       CONTINUE
16635   230     CONTINUE
16636
16637         ELSEIF(ISUB.EQ.6) THEN
16638 C...Z0 + W+/- -> W+/-
16639
16640         ELSEIF(ISUB.EQ.7) THEN
16641 C...W+ + W- -> Z0
16642
16643         ELSEIF(ISUB.EQ.8) THEN
16644 C...W+ + W- -> h0
16645           CALL PYWIDT(25,SH,WDTP,WDTE)
16646           HS=SHR*WDTP(0)
16647           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
16648           IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
16649           HP=AEM/(8D0*XW)*SH/SQMW*SH
16650           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16651           HI=HP/2D0
16652           FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
16653           DO 250 I=MMIN1,MMAX1
16654             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250
16655             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
16656             DO 240 J=MMIN2,MMAX2
16657               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240
16658               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
16659               IF(EI*EJ.GT.0D0) GOTO 240
16660               NCHN=NCHN+1
16661               ISIG(NCHN,1)=I
16662               ISIG(NCHN,2)=J
16663               ISIG(NCHN,3)=1
16664               SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
16665   240       CONTINUE
16666   250     CONTINUE
16667
16668 C...B: 2 -> 2, tree diagrams
16669
16670         ELSEIF(ISUB.EQ.10) THEN
16671 C...f + f' -> f + f' (gamma/Z/W exchange)
16672           FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
16673           FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
16674           FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
16675           FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
16676           DO 270 I=MMIN1,MMAX1
16677             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
16678             IA=IABS(I)
16679             DO 260 J=MMIN2,MMAX2
16680               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
16681               JA=IABS(J)
16682 C...Electroweak couplings
16683               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
16684               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
16685               VI=AI-4D0*EI*XWV
16686               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
16687               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
16688               VJ=AJ-4D0*EJ*XWV
16689               EPSIJ=ISIGN(1,I*J)
16690 C...gamma/Z exchange, only gamma exchange, or only Z exchange
16691               IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
16692                 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
16693                   FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
16694      &            (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
16695      &            FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
16696      &            4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16697                 ELSEIF(MSTP(21).EQ.2) THEN
16698                   FACNCF=FACGGF*EI**2*EJ**2
16699                 ELSE
16700                   FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
16701      &            (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
16702                 ENDIF
16703                 NCHN=NCHN+1
16704                 ISIG(NCHN,1)=I
16705                 ISIG(NCHN,2)=J
16706                 ISIG(NCHN,3)=1
16707                 SIGH(NCHN)=FACNCF
16708               ENDIF
16709 C...W exchange
16710               IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
16711                 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
16712                 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
16713                 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
16714                 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
16715                 NCHN=NCHN+1
16716                 ISIG(NCHN,1)=I
16717                 ISIG(NCHN,2)=J
16718                 ISIG(NCHN,3)=2
16719                 SIGH(NCHN)=FACCCF
16720               ENDIF
16721   260       CONTINUE
16722   270     CONTINUE
16723         ENDIF
16724
16725       ELSEIF(ISUB.LE.20) THEN
16726         IF(ISUB.EQ.11) THEN
16727 C...f + f' -> f + f' (g exchange)
16728           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
16729           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
16730      &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
16731           FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
16732      &    MSTP(34)*2D0/3D0*SH2/(TH*UH))
16733           IF(MSTP(5).GE.1) THEN
16734 C...Modifications from contact interactions (compositeness)
16735             FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4)
16736             FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16737      &      (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4)
16738             FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)*
16739      &      (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4)
16740             FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4)
16741           ENDIF
16742           DO 290 I=MMIN1,MMAX1
16743             IA=IABS(I)
16744             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290
16745             DO 280 J=MMIN2,MMAX2
16746               JA=IABS(J)
16747               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280
16748               NCHN=NCHN+1
16749               ISIG(NCHN,1)=I
16750               ISIG(NCHN,2)=J
16751               ISIG(NCHN,3)=1
16752               IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR.
16753      &        JA.GE.3))) THEN
16754                 SIGH(NCHN)=FACQQ1
16755                 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
16756               ELSE
16757                 SIGH(NCHN)=FACCI1
16758                 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
16759                 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
16760               ENDIF
16761               IF(I.EQ.J) THEN
16762                 SIGH(NCHN)=0.5D0*SIGH(NCHN)
16763                 NCHN=NCHN+1
16764                 ISIG(NCHN,1)=I
16765                 ISIG(NCHN,2)=J
16766                 ISIG(NCHN,3)=2
16767                 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN
16768                   SIGH(NCHN)=0.5D0*FACQQ2
16769                 ELSE
16770                   SIGH(NCHN)=0.5D0*FACCI2
16771                 ENDIF
16772               ENDIF
16773   280       CONTINUE
16774   290     CONTINUE
16775
16776         ELSEIF(ISUB.EQ.12) THEN
16777 C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
16778           CALL PYWIDT(21,SH,WDTP,WDTE)
16779           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
16780      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16781           IF(MSTP(5).EQ.1) THEN
16782 C...Modifications from contact interactions (compositeness)
16783             FACCIB=FACQQB
16784             DO 300 I=1,2
16785               FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+
16786      &        WDTE(I,2)+WDTE(I,4))
16787   300       CONTINUE
16788           ELSEIF(MSTP(5).GE.2) THEN
16789             FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)*
16790      &      (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
16791           ENDIF
16792           DO 310 I=MMINA,MMAXA
16793             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16794      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
16795             NCHN=NCHN+1
16796             ISIG(NCHN,1)=I
16797             ISIG(NCHN,2)=-I
16798             ISIG(NCHN,3)=1
16799             IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN
16800               SIGH(NCHN)=FACQQB
16801             ELSE
16802               SIGH(NCHN)=FACCIB
16803             ENDIF
16804   310     CONTINUE
16805
16806         ELSEIF(ISUB.EQ.13) THEN
16807 C...f + fbar -> g + g (q + qbar -> g + g only)
16808           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
16809      &    UH2/SH2)
16810           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
16811      &    TH2/SH2)
16812           DO 320 I=MMINA,MMAXA
16813             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16814      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
16815             NCHN=NCHN+1
16816             ISIG(NCHN,1)=I
16817             ISIG(NCHN,2)=-I
16818             ISIG(NCHN,3)=1
16819             SIGH(NCHN)=0.5D0*FACGG1
16820             NCHN=NCHN+1
16821             ISIG(NCHN,1)=I
16822             ISIG(NCHN,2)=-I
16823             ISIG(NCHN,3)=2
16824             SIGH(NCHN)=0.5D0*FACGG2
16825   320     CONTINUE
16826
16827         ELSEIF(ISUB.EQ.14) THEN
16828 C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
16829           FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
16830           DO 330 I=MMINA,MMAXA
16831             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16832      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
16833             EI=KCHG(IABS(I),1)/3D0
16834             NCHN=NCHN+1
16835             ISIG(NCHN,1)=I
16836             ISIG(NCHN,2)=-I
16837             ISIG(NCHN,3)=1
16838             SIGH(NCHN)=FACGG*EI**2
16839   330     CONTINUE
16840
16841         ELSEIF(ISUB.EQ.15) THEN
16842 C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
16843           FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16844 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16845           HFGG=0D0
16846           HFGZ=0D0
16847           HFZZ=0D0
16848           RADC4=1D0+PYALPS(SQM4)/PARU(1)
16849           DO 340 I=1,MIN(16,MDCY(23,3))
16850             IDC=I+MDCY(23,2)-1
16851             IF(MDME(IDC,1).LT.0) GOTO 340
16852             IMDM=0
16853             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16854      &      IMDM=1
16855             IF(I.LE.8) THEN
16856               EF=KCHG(I,1)/3D0
16857               AF=SIGN(1D0,EF+0.1D0)
16858               VF=AF-4D0*EF*XWV
16859             ELSEIF(I.LE.16) THEN
16860               EF=KCHG(I+2,1)/3D0
16861               AF=SIGN(1D0,EF+0.1D0)
16862               VF=AF-4D0*EF*XWV
16863             ENDIF
16864             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16865             IF(4D0*RM1.LT.1D0) THEN
16866               FCOF=1D0
16867               IF(I.LE.8) FCOF=3D0*RADC4
16868               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16869               IF(IMDM.EQ.1) THEN
16870                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16871                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16872                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16873      &          AF**2*(1D0-4D0*RM1))*BE34
16874               ENDIF
16875             ENDIF
16876   340     CONTINUE
16877 C...Propagators: as simulated in PYOFSH and as desired
16878           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16879           MINT(15)=1
16880           MINT(61)=1
16881           CALL PYWIDT(23,SQM4,WDTP,WDTE)
16882           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16883           HFGG=HFGG*HFAEM*VINT(111)/SQM4
16884           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16885           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16886 C...Loop over flavours; consider full gamma/Z structure
16887           DO 350 I=MMINA,MMAXA
16888             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
16889      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
16890             EI=KCHG(IABS(I),1)/3D0
16891             AI=SIGN(1D0,EI)
16892             VI=AI-4D0*EI*XWV
16893             NCHN=NCHN+1
16894             ISIG(NCHN,1)=I
16895             ISIG(NCHN,2)=-I
16896             ISIG(NCHN,3)=1
16897             SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
16898      &      (VI**2+AI**2)*HFZZ)/HBW4
16899   350     CONTINUE
16900
16901         ELSEIF(ISUB.EQ.16) THEN
16902 C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
16903           FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16904 C...Propagators: as simulated in PYOFSH and as desired
16905           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
16906           CALL PYWIDT(24,SQM4,WDTP,WDTE)
16907           GMMWC=SQRT(SQM4)*WDTP(0)
16908           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
16909           FACWG=FACWG*HBW4C/HBW4
16910           DO 370 I=MMIN1,MMAX1
16911             IA=IABS(I)
16912             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370
16913             DO 360 J=MMIN2,MMAX2
16914               JA=IABS(J)
16915               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360
16916               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
16917               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
16918               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
16919               FCKM=VCKM((IA+1)/2,(JA+1)/2)
16920               NCHN=NCHN+1
16921               ISIG(NCHN,1)=I
16922               ISIG(NCHN,2)=J
16923               ISIG(NCHN,3)=1
16924               SIGH(NCHN)=FACWG*FCKM*WIDSC
16925   360       CONTINUE
16926   370     CONTINUE
16927
16928         ELSEIF(ISUB.EQ.17) THEN
16929 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
16930
16931         ELSEIF(ISUB.EQ.18) THEN
16932 C...f + fbar -> gamma + gamma
16933           FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
16934           DO 380 I=MMINA,MMAXA
16935             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
16936             EI=KCHG(IABS(I),1)/3D0
16937             FCOI=1D0
16938             IF(IABS(I).LE.10) FCOI=FACA/3D0
16939             NCHN=NCHN+1
16940             ISIG(NCHN,1)=I
16941             ISIG(NCHN,2)=-I
16942             ISIG(NCHN,3)=1
16943             SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
16944   380     CONTINUE
16945
16946         ELSEIF(ISUB.EQ.19) THEN
16947 C...f + fbar -> gamma + (gamma*/Z0)
16948           FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
16949 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
16950           HFGG=0D0
16951           HFGZ=0D0
16952           HFZZ=0D0
16953           RADC4=1D0+PYALPS(SQM4)/PARU(1)
16954           DO 390 I=1,MIN(16,MDCY(23,3))
16955             IDC=I+MDCY(23,2)-1
16956             IF(MDME(IDC,1).LT.0) GOTO 390
16957             IMDM=0
16958             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
16959      &      IMDM=1
16960             IF(I.LE.8) THEN
16961               EF=KCHG(I,1)/3D0
16962               AF=SIGN(1D0,EF+0.1D0)
16963               VF=AF-4D0*EF*XWV
16964             ELSEIF(I.LE.16) THEN
16965               EF=KCHG(I+2,1)/3D0
16966               AF=SIGN(1D0,EF+0.1D0)
16967               VF=AF-4D0*EF*XWV
16968             ENDIF
16969             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
16970             IF(4D0*RM1.LT.1D0) THEN
16971               FCOF=1D0
16972               IF(I.LE.8) FCOF=3D0*RADC4
16973               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
16974               IF(IMDM.EQ.1) THEN
16975                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
16976                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
16977                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
16978      &          AF**2*(1D0-4D0*RM1))*BE34
16979               ENDIF
16980             ENDIF
16981   390     CONTINUE
16982 C...Propagators: as simulated in PYOFSH and as desired
16983           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
16984           MINT(15)=1
16985           MINT(61)=1
16986           CALL PYWIDT(23,SQM4,WDTP,WDTE)
16987           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
16988           HFGG=HFGG*HFAEM*VINT(111)/SQM4
16989           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
16990           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
16991 C...Loop over flavours; consider full gamma/Z structure
16992           DO 400 I=MMINA,MMAXA
16993             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
16994             EI=KCHG(IABS(I),1)/3D0
16995             AI=SIGN(1D0,EI)
16996             VI=AI-4D0*EI*XWV
16997             FCOI=1D0
16998             IF(IABS(I).LE.10) FCOI=FACA/3D0
16999             NCHN=NCHN+1
17000             ISIG(NCHN,1)=I
17001             ISIG(NCHN,2)=-I
17002             ISIG(NCHN,3)=1
17003             SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17004      &      (VI**2+AI**2)*HFZZ)/HBW4
17005   400     CONTINUE
17006
17007         ELSEIF(ISUB.EQ.20) THEN
17008 C...f + fbar' -> gamma + W+/-
17009           FACGW=COMFAC*0.5D0*AEM**2/XW
17010 C...Propagators: as simulated in PYOFSH and as desired
17011           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17012           CALL PYWIDT(24,SQM4,WDTP,WDTE)
17013           GMMWC=SQRT(SQM4)*WDTP(0)
17014           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17015           FACGW=FACGW*HBW4C/HBW4
17016 C...Anomalous couplings
17017           TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
17018           TERM2=0D0
17019           TERM3=0D0
17020           IF(MSTP(5).GE.1) THEN
17021             TERM2=PARU(153)*(TH-UH)/(TH+UH)
17022             TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/
17023      &      (4D0*SQMW))/(TH+UH)**2
17024           ENDIF
17025           DO 420 I=MMIN1,MMAX1
17026             IA=IABS(I)
17027             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420
17028             DO 410 J=MMIN2,MMAX2
17029               JA=IABS(J)
17030               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410
17031               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410
17032               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17033      &        GOTO 410
17034               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17035               WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17036               IF(IA.LE.10) THEN
17037                 FACWR=UH/(TH+UH)-1D0/3D0
17038                 FCKM=VCKM((IA+1)/2,(JA+1)/2)
17039                 FCOI=FACA/3D0
17040               ELSE
17041                 FACWR=-TH/(TH+UH)
17042                 FCKM=1D0
17043                 FCOI=1D0
17044               ENDIF
17045               FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
17046               NCHN=NCHN+1
17047               ISIG(NCHN,1)=I
17048               ISIG(NCHN,2)=J
17049               ISIG(NCHN,3)=1
17050               SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
17051   410       CONTINUE
17052   420     CONTINUE
17053         ENDIF
17054
17055       ELSEIF(ISUB.LE.30) THEN
17056         IF(ISUB.EQ.21) THEN
17057 C...f + fbar -> gamma + h0
17058
17059         ELSEIF(ISUB.EQ.22) THEN
17060 C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
17061 C...Kinematics dependence
17062           FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
17063      &    SQM3*SQM4*(1D0/TH2+1D0/UH2))
17064 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17065           DO 440 I=1,6
17066             DO 430 J=1,3
17067               HGZ(I,J)=0D0
17068   430       CONTINUE
17069   440     CONTINUE
17070           RADC3=1D0+PYALPS(SQM3)/PARU(1)
17071           RADC4=1D0+PYALPS(SQM4)/PARU(1)
17072           DO 450 I=1,MIN(16,MDCY(23,3))
17073             IDC=I+MDCY(23,2)-1
17074             IF(MDME(IDC,1).LT.0) GOTO 450
17075             IMDM=0
17076             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
17077             IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
17078             IF(I.LE.8) THEN
17079               EF=KCHG(I,1)/3D0
17080               AF=SIGN(1D0,EF+0.1D0)
17081               VF=AF-4D0*EF*XWV
17082             ELSEIF(I.LE.16) THEN
17083               EF=KCHG(I+2,1)/3D0
17084               AF=SIGN(1D0,EF+0.1D0)
17085               VF=AF-4D0*EF*XWV
17086             ENDIF
17087             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
17088             IF(4D0*RM1.LT.1D0) THEN
17089               FCOF=1D0
17090               IF(I.LE.8) FCOF=3D0*RADC3
17091               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17092               IF(IMDM.GE.1) THEN
17093                 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17094                 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17095                 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17096      &          AF**2*(1D0-4D0*RM1))*BE34
17097               ENDIF
17098             ENDIF
17099             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17100             IF(4D0*RM1.LT.1D0) THEN
17101               FCOF=1D0
17102               IF(I.LE.8) FCOF=3D0*RADC4
17103               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17104               IF(IMDM.GE.1) THEN
17105                 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17106                 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17107                 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
17108      &          AF**2*(1D0-4D0*RM1))*BE34
17109               ENDIF
17110             ENDIF
17111   450     CONTINUE
17112 C...Propagators: as simulated in PYOFSH and as desired
17113           HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
17114           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17115           MINT(15)=1
17116           MINT(61)=1
17117           CALL PYWIDT(23,SQM3,WDTP,WDTE)
17118           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17119           DO 460 J=1,3
17120             HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
17121             HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
17122             HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
17123   460     CONTINUE
17124           MINT(61)=1
17125           CALL PYWIDT(23,SQM4,WDTP,WDTE)
17126           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17127           DO 470 J=1,3
17128             HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
17129             HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
17130             HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
17131   470     CONTINUE
17132 C...Loop over flavours; separate left- and right-handed couplings
17133           DO 490 I=MMINA,MMAXA
17134             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490
17135             EI=KCHG(IABS(I),1)/3D0
17136             AI=SIGN(1D0,EI)
17137             VI=AI-4D0*EI*XWV
17138             VALI=VI-AI
17139             VARI=VI+AI
17140             FCOI=1D0
17141             IF(IABS(I).LE.10) FCOI=FACA/3D0
17142             DO 480 J=1,3
17143               HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
17144               HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
17145               HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
17146               HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
17147   480       CONTINUE
17148             FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
17149      &      HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
17150      &      HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
17151      &      HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
17152             NCHN=NCHN+1
17153             ISIG(NCHN,1)=I
17154             ISIG(NCHN,2)=-I
17155             ISIG(NCHN,3)=1
17156             SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
17157   490     CONTINUE
17158
17159         ELSEIF(ISUB.EQ.23) THEN
17160 C...f + fbar' -> Z0 + W+/-
17161           FACZW=COMFAC*0.5D0*(AEM/XW)**2
17162           FACZW=FACZW*WIDS(23,2)
17163           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17164           FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17165           DO 510 I=MMIN1,MMAX1
17166             IA=IABS(I)
17167             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510
17168             DO 500 J=MMIN2,MMAX2
17169               JA=IABS(J)
17170               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500
17171               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500
17172               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17173      &        GOTO 500
17174               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17175               EI=KCHG(IA,1)/3D0
17176               AI=SIGN(1D0,EI+0.1D0)
17177               VI=AI-4D0*EI*XWV
17178               EJ=KCHG(JA,1)/3D0
17179               AJ=SIGN(1D0,EJ+0.1D0)
17180               VJ=AJ-4D0*EJ*XWV
17181               IF(VI+AI.GT.0) THEN
17182                 VISAV=VI
17183                 AISAV=AI
17184                 VI=VJ
17185                 AI=AJ
17186                 VJ=VISAV
17187                 AJ=AISAV
17188               ENDIF
17189               FCKM=1D0
17190               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17191               FCOI=1D0
17192               IF(IA.LE.10) FCOI=FACA/3D0
17193               NCHN=NCHN+1
17194               ISIG(NCHN,1)=I
17195               ISIG(NCHN,2)=J
17196               ISIG(NCHN,3)=1
17197               SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
17198      &        (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
17199      &        (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
17200      &        THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
17201      &        SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
17202      &        WIDS(24,(5-KCHW)/2)
17203   500       CONTINUE
17204   510     CONTINUE
17205
17206         ELSEIF(ISUB.EQ.24) THEN
17207 C...f + fbar -> Z0 + h0 (or H0, or A0)
17208           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17209           FACHZ=COMFAC*8D0*(AEM*XWC)**2*
17210      &    (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
17211           FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
17212           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
17213      &    PARU(154+10*IHIGG)**2
17214           DO 520 I=MMINA,MMAXA
17215             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
17216             EI=KCHG(IABS(I),1)/3D0
17217             AI=SIGN(1D0,EI)
17218             VI=AI-4D0*EI*XWV
17219             FCOI=1D0
17220             IF(IABS(I).LE.10) FCOI=FACA/3D0
17221             NCHN=NCHN+1
17222             ISIG(NCHN,1)=I
17223             ISIG(NCHN,2)=-I
17224             ISIG(NCHN,3)=1
17225             SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
17226   520     CONTINUE
17227
17228         ELSEIF(ISUB.EQ.25) THEN
17229 C...f + fbar -> W+ + W-
17230 C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
17231           CALL PYWIDT(23,SH,WDTP,WDTE)
17232           GMMZC=SHR*WDTP(0)
17233           HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
17234           HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
17235           CALL PYWIDT(24,SQM3,WDTP,WDTE)
17236           GMMW3=SQRT(SQM3)*WDTP(0)
17237           HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
17238           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17239           CALL PYWIDT(24,SQM4,WDTP,WDTE)
17240           GMMW4=SQRT(SQM4)*WDTP(0)
17241           HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
17242 C...Kinematical functions
17243           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17244           THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
17245           GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
17246           GT=THUH34+4D0*THUH/TH2
17247           GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
17248           GU=THUH34+4D0*THUH/UH2
17249           GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
17250 C...Common factors and couplings
17251           FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
17252           FACWW=FACWW*WIDS(24,1)
17253           CGG=AEM**2/2D0
17254           CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
17255           CZZ=AEM**2/(32D0*XW**2)*HBWZC
17256           CNG=AEM**2/(4D0*XW)
17257           CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
17258           CNN=AEM**2/(16D0*XW**2)
17259 C...Coulomb factor for W+W- pair
17260           IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
17261             COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
17262             COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
17263             IF(COULE.LT.100D0*PMAS(24,2)) THEN
17264               COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17265      &        PMAS(24,2)**2)-COULE))
17266             ELSE
17267               COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
17268             ENDIF
17269             IF(COULE.GT.-100D0*PMAS(24,2)) THEN
17270               COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
17271      &        PMAS(24,2)**2)+COULE))
17272             ELSE
17273               COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
17274      &        ABS(COULE)))
17275             ENDIF
17276             IF(MSTP(40).EQ.1) THEN
17277               COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
17278      &        MAX(1D-10,2D0*COULP*COULP1))
17279               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17280             ELSEIF(MSTP(40).EQ.2) THEN
17281               COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2))
17282               COULCP=CMPLX(0.,SNGL(COULP))
17283               COULCD=(COULCK+COULCP)/(COULCK-COULCP)
17284               COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD)
17285               COULCS=CMPLX(0.,0.)
17286               NSTP=100
17287               DO 530 ISTP=1,NSTP
17288                 COULXX=(ISTP-0.5)/NSTP
17289                 COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/
17290      &          (1.+COULXX/COULCD))
17291   530         CONTINUE
17292               COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)*
17293      &        (COULCS/NSTP)
17294               FACCOU=ABS(COULCR)**2
17295             ELSEIF(MSTP(40).EQ.3) THEN
17296               COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
17297      &        COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
17298               FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
17299             ENDIF
17300           ELSEIF(MSTP(40).EQ.4) THEN
17301             FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
17302           ELSE
17303             FACCOU=1D0
17304           ENDIF
17305           VINT(95)=FACCOU
17306           FACWW=FACWW*FACCOU
17307 C...Loop over allowed flavours
17308           DO 540 I=MMINA,MMAXA
17309             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540
17310             EI=KCHG(IABS(I),1)/3D0
17311             AI=SIGN(1D0,EI+0.1D0)
17312             VI=AI-4D0*EI*XWV
17313             FCOI=1D0
17314             IF(IABS(I).LE.10) FCOI=FACA/3D0
17315             IF(AI.LT.0D0) THEN
17316               DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
17317      &        (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
17318             ELSE
17319               DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
17320      &        (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
17321             ENDIF
17322             NCHN=NCHN+1
17323             ISIG(NCHN,1)=I
17324             ISIG(NCHN,2)=-I
17325             ISIG(NCHN,3)=1
17326             SIGH(NCHN)=FACWW*FCOI*DSIGWW
17327   540     CONTINUE
17328
17329         ELSEIF(ISUB.EQ.26) THEN
17330 C...f + fbar' -> W+/- + h0 (or H0, or A0)
17331           THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
17332           FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
17333      &    ((SH-SQMW)**2+GMMW**2)
17334           FACHW=FACHW*WIDS(KFHIGG,2)
17335           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
17336      &    PARU(155+10*IHIGG)**2
17337           DO 560 I=MMIN1,MMAX1
17338             IA=IABS(I)
17339             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560
17340             DO 550 J=MMIN2,MMAX2
17341               JA=IABS(J)
17342               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550
17343               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550
17344               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
17345      &        GOTO 550
17346               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
17347               FCKM=1D0
17348               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
17349               FCOI=1D0
17350               IF(IA.LE.10) FCOI=FACA/3D0
17351               NCHN=NCHN+1
17352               ISIG(NCHN,1)=I
17353               ISIG(NCHN,2)=J
17354               ISIG(NCHN,3)=1
17355               SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
17356   550       CONTINUE
17357   560     CONTINUE
17358
17359         ELSEIF(ISUB.EQ.27) THEN
17360 C...f + fbar -> h0 + h0
17361
17362         ELSEIF(ISUB.EQ.28) THEN
17363 C...f + g -> f + g (q + g -> q + g only)
17364           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
17365      &    UH/SH)*FACA
17366           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
17367      &    SH/UH)
17368           DO 580 I=MMINA,MMAXA
17369             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580
17370             DO 570 ISDE=1,2
17371               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570
17372               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570
17373               NCHN=NCHN+1
17374               ISIG(NCHN,ISDE)=I
17375               ISIG(NCHN,3-ISDE)=21
17376               ISIG(NCHN,3)=1
17377               SIGH(NCHN)=FACQG1
17378               NCHN=NCHN+1
17379               ISIG(NCHN,ISDE)=I
17380               ISIG(NCHN,3-ISDE)=21
17381               ISIG(NCHN,3)=2
17382               SIGH(NCHN)=FACQG2
17383   570       CONTINUE
17384   580     CONTINUE
17385
17386         ELSEIF(ISUB.EQ.29) THEN
17387 C...f + g -> f + gamma (q + g -> q + gamma only)
17388           FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
17389           DO 600 I=MMINA,MMAXA
17390             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600
17391             EI=KCHG(IABS(I),1)/3D0
17392             FACGQ=FGQ*EI**2
17393             DO 590 ISDE=1,2
17394               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590
17395               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590
17396               NCHN=NCHN+1
17397               ISIG(NCHN,ISDE)=I
17398               ISIG(NCHN,3-ISDE)=21
17399               ISIG(NCHN,3)=1
17400               SIGH(NCHN)=FACGQ
17401   590       CONTINUE
17402   600     CONTINUE
17403
17404         ELSEIF(ISUB.EQ.30) THEN
17405 C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
17406           FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
17407      &    (-SH*UH)
17408 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17409           HFGG=0D0
17410           HFGZ=0D0
17411           HFZZ=0D0
17412           RADC4=1D0+PYALPS(SQM4)/PARU(1)
17413           DO 610 I=1,MIN(16,MDCY(23,3))
17414             IDC=I+MDCY(23,2)-1
17415             IF(MDME(IDC,1).LT.0) GOTO 610
17416             IMDM=0
17417             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17418      &      IMDM=1
17419             IF(I.LE.8) THEN
17420               EF=KCHG(I,1)/3D0
17421               AF=SIGN(1D0,EF+0.1D0)
17422               VF=AF-4D0*EF*XWV
17423             ELSEIF(I.LE.16) THEN
17424               EF=KCHG(I+2,1)/3D0
17425               AF=SIGN(1D0,EF+0.1D0)
17426               VF=AF-4D0*EF*XWV
17427             ENDIF
17428             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17429             IF(4D0*RM1.LT.1D0) THEN
17430               FCOF=1D0
17431               IF(I.LE.8) FCOF=3D0*RADC4
17432               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17433               IF(IMDM.EQ.1) THEN
17434                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17435                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17436                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17437      &          AF**2*(1D0-4D0*RM1))*BE34
17438               ENDIF
17439             ENDIF
17440   610     CONTINUE
17441 C...Propagators: as simulated in PYOFSH and as desired
17442           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17443           MINT(15)=1
17444           MINT(61)=1
17445           CALL PYWIDT(23,SQM4,WDTP,WDTE)
17446           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17447           HFGG=HFGG*HFAEM*VINT(111)/SQM4
17448           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17449           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17450 C...Loop over flavours; consider full gamma/Z structure
17451           DO 630 I=MMINA,MMAXA
17452             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630
17453             EI=KCHG(IABS(I),1)/3D0
17454             AI=SIGN(1D0,EI)
17455             VI=AI-4D0*EI*XWV
17456             FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
17457      &      (VI**2+AI**2)*HFZZ)/HBW4
17458             DO 620 ISDE=1,2
17459               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620
17460               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620
17461               NCHN=NCHN+1
17462               ISIG(NCHN,ISDE)=I
17463               ISIG(NCHN,3-ISDE)=21
17464               ISIG(NCHN,3)=1
17465               SIGH(NCHN)=FACZQ
17466   620       CONTINUE
17467   630     CONTINUE
17468         ENDIF
17469
17470       ELSEIF(ISUB.LE.40) THEN
17471         IF(ISUB.EQ.31) THEN
17472 C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
17473           FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
17474      &    (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
17475 C...Propagators: as simulated in PYOFSH and as desired
17476           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17477           CALL PYWIDT(24,SQM4,WDTP,WDTE)
17478           GMMWC=SQRT(SQM4)*WDTP(0)
17479           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17480           FACWQ=FACWQ*HBW4C/HBW4
17481           DO 650 I=MMINA,MMAXA
17482             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650
17483             IA=IABS(I)
17484             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17485             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17486             DO 640 ISDE=1,2
17487               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640
17488               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640
17489               NCHN=NCHN+1
17490               ISIG(NCHN,ISDE)=I
17491               ISIG(NCHN,3-ISDE)=21
17492               ISIG(NCHN,3)=1
17493               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17494   640       CONTINUE
17495   650     CONTINUE
17496
17497         ELSEIF(ISUB.EQ.32) THEN
17498 C...f + g -> f + h0 (q + g -> q + h0 only)
17499
17500         ELSEIF(ISUB.EQ.33) THEN
17501 C...f + gamma -> f + g (q + gamma -> q + g only)
17502           FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
17503           DO 670 I=MMINA,MMAXA
17504             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670
17505             EI=KCHG(IABS(I),1)/3D0
17506             FACGQ=FGQ*EI**2
17507             DO 660 ISDE=1,2
17508               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660
17509               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660
17510               NCHN=NCHN+1
17511               ISIG(NCHN,ISDE)=I
17512               ISIG(NCHN,3-ISDE)=22
17513               ISIG(NCHN,3)=1
17514               SIGH(NCHN)=FACGQ
17515   660       CONTINUE
17516   670     CONTINUE
17517
17518         ELSEIF(ISUB.EQ.34) THEN
17519 C...f + gamma -> f + gamma
17520           FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
17521           DO 690 I=MMINA,MMAXA
17522             IF(I.EQ.0) GOTO 690
17523             EI=KCHG(IABS(I),1)/3D0
17524             FACGQ=FGQ*EI**4
17525             DO 680 ISDE=1,2
17526               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680
17527               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680
17528               NCHN=NCHN+1
17529               ISIG(NCHN,ISDE)=I
17530               ISIG(NCHN,3-ISDE)=22
17531               ISIG(NCHN,3)=1
17532               SIGH(NCHN)=FACGQ
17533   680       CONTINUE
17534   690     CONTINUE
17535
17536         ELSEIF(ISUB.EQ.35) THEN
17537 C...f + gamma -> f + (gamma*/Z0)
17538           FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH)
17539           FZQD=SQPTH*SQM4-SH*UH
17540 C...gamma, gamma/Z interference and Z couplings to final fermion pairs
17541           HFGG=0D0
17542           HFGZ=0D0
17543           HFZZ=0D0
17544           RADC4=1D0+PYALPS(SQM4)/PARU(1)
17545           DO 700 I=1,MIN(16,MDCY(23,3))
17546             IDC=I+MDCY(23,2)-1
17547             IF(MDME(IDC,1).LT.0) GOTO 700
17548             IMDM=0
17549             IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
17550      &      IMDM=1
17551             IF(I.LE.8) THEN
17552               EF=KCHG(I,1)/3D0
17553               AF=SIGN(1D0,EF+0.1D0)
17554               VF=AF-4D0*EF*XWV
17555             ELSEIF(I.LE.16) THEN
17556               EF=KCHG(I+2,1)/3D0
17557               AF=SIGN(1D0,EF+0.1D0)
17558               VF=AF-4D0*EF*XWV
17559             ENDIF
17560             RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
17561             IF(4D0*RM1.LT.1D0) THEN
17562               FCOF=1D0
17563               IF(I.LE.8) FCOF=3D0*RADC4
17564               BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
17565               IF(IMDM.EQ.1) THEN
17566                 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
17567                 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
17568                 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
17569      &          AF**2*(1D0-4D0*RM1))*BE34
17570               ENDIF
17571             ENDIF
17572   700     CONTINUE
17573 C...Propagators: as simulated in PYOFSH and as desired
17574           HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
17575           MINT(15)=1
17576           MINT(61)=1
17577           CALL PYWIDT(23,SQM4,WDTP,WDTE)
17578           HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
17579           HFGG=HFGG*HFAEM*VINT(111)/SQM4
17580           HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
17581           HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
17582 C...Loop over flavours; consider full gamma/Z structure
17583           DO 720 I=MMINA,MMAXA
17584             IF(I.EQ.0) GOTO 720
17585             EI=KCHG(IABS(I),1)/3D0
17586             AI=SIGN(1D0,EI)
17587             VI=AI-4D0*EI*XWV
17588             FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
17589      &      (VI**2+AI**2)*HFZZ)/HBW4
17590             DO 710 ISDE=1,2
17591               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710
17592               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710
17593               NCHN=NCHN+1
17594               ISIG(NCHN,ISDE)=I
17595               ISIG(NCHN,3-ISDE)=22
17596               ISIG(NCHN,3)=1
17597               SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD)
17598   710       CONTINUE
17599   720     CONTINUE
17600
17601         ELSEIF(ISUB.EQ.36) THEN
17602 C...f + gamma -> f' + W+/-
17603           FWQ=COMFAC*AEM**2/(2D0*XW)*
17604      &    (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
17605 C...Propagators: as simulated in PYOFSH and as desired
17606           HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
17607           CALL PYWIDT(24,SQM4,WDTP,WDTE)
17608           GMMWC=SQRT(SQM4)*WDTP(0)
17609           HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
17610           FWQ=FWQ*HBW4C/HBW4
17611           DO 740 I=MMINA,MMAXA
17612             IF(I.EQ.0) GOTO 740
17613             IA=IABS(I)
17614             EIA=ABS(KCHG(IABS(I),1)/3D0)
17615             FACWQ=FWQ*(EIA-SH/(SH+UH))**2
17616             KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
17617             WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
17618             DO 730 ISDE=1,2
17619               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730
17620               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730
17621               NCHN=NCHN+1
17622               ISIG(NCHN,ISDE)=I
17623               ISIG(NCHN,3-ISDE)=22
17624               ISIG(NCHN,3)=1
17625               SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
17626   730       CONTINUE
17627   740     CONTINUE
17628
17629         ELSEIF(ISUB.EQ.37) THEN
17630 C...f + gamma -> f + h0
17631
17632         ELSEIF(ISUB.EQ.38) THEN
17633 C...f + Z0 -> f + g (q + Z0 -> q + g only)
17634
17635         ELSEIF(ISUB.EQ.39) THEN
17636 C...f + Z0 -> f + gamma
17637
17638         ELSEIF(ISUB.EQ.40) THEN
17639 C...f + Z0 -> f + Z0
17640         ENDIF
17641
17642       ELSEIF(ISUB.LE.50) THEN
17643         IF(ISUB.EQ.41) THEN
17644 C...f + Z0 -> f' + W+/-
17645
17646         ELSEIF(ISUB.EQ.42) THEN
17647 C...f + Z0 -> f + h0
17648
17649         ELSEIF(ISUB.EQ.43) THEN
17650 C...f + W+/- -> f' + g (q + W+/- -> q' + g only)
17651
17652         ELSEIF(ISUB.EQ.44) THEN
17653 C...f + W+/- -> f' + gamma
17654
17655         ELSEIF(ISUB.EQ.45) THEN
17656 C...f + W+/- -> f' + Z0
17657
17658         ELSEIF(ISUB.EQ.46) THEN
17659 C...f + W+/- -> f' + W+/-
17660
17661         ELSEIF(ISUB.EQ.47) THEN
17662 C...f + W+/- -> f' + h0
17663
17664         ELSEIF(ISUB.EQ.48) THEN
17665 C...f + h0 -> f + g (q + h0 -> q + g only)
17666
17667         ELSEIF(ISUB.EQ.49) THEN
17668 C...f + h0 -> f + gamma
17669
17670         ELSEIF(ISUB.EQ.50) THEN
17671 C...f + h0 -> f + Z0
17672         ENDIF
17673
17674       ELSEIF(ISUB.LE.60) THEN
17675         IF(ISUB.EQ.51) THEN
17676 C...f + h0 -> f' + W+/-
17677
17678         ELSEIF(ISUB.EQ.52) THEN
17679 C...f + h0 -> f + h0
17680
17681         ELSEIF(ISUB.EQ.53) THEN
17682 C...g + g -> f + fbar (g + g -> q + qbar only)
17683           CALL PYWIDT(21,SH,WDTP,WDTE)
17684           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
17685      &    UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17686           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
17687      &    TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
17688           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750
17689           NCHN=NCHN+1
17690           ISIG(NCHN,1)=21
17691           ISIG(NCHN,2)=21
17692           ISIG(NCHN,3)=1
17693           SIGH(NCHN)=FACQQ1
17694           NCHN=NCHN+1
17695           ISIG(NCHN,1)=21
17696           ISIG(NCHN,2)=21
17697           ISIG(NCHN,3)=2
17698           SIGH(NCHN)=FACQQ2
17699   750     CONTINUE
17700
17701         ELSEIF(ISUB.EQ.54) THEN
17702 C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
17703           CALL PYWIDT(21,SH,WDTP,WDTE)
17704           WDTESU=0D0
17705           DO 760 I=1,MIN(8,MDCY(21,3))
17706             EF=KCHG(I,1)/3D0
17707             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17708      &      WDTE(I,4))
17709   760     CONTINUE
17710           FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
17711           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
17712             NCHN=NCHN+1
17713             ISIG(NCHN,1)=21
17714             ISIG(NCHN,2)=22
17715             ISIG(NCHN,3)=1
17716             SIGH(NCHN)=FACQQ
17717           ENDIF
17718           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
17719             NCHN=NCHN+1
17720             ISIG(NCHN,1)=22
17721             ISIG(NCHN,2)=21
17722             ISIG(NCHN,3)=1
17723             SIGH(NCHN)=FACQQ
17724           ENDIF
17725
17726         ELSEIF(ISUB.EQ.55) THEN
17727 C...g + Z -> f + fbar (g + Z -> q + qbar only)
17728
17729         ELSEIF(ISUB.EQ.56) THEN
17730 C...g + W -> f + f'bar (g + W -> q + q'bar only)
17731
17732         ELSEIF(ISUB.EQ.57) THEN
17733 C...g + h0 -> f + fbar (g + h0 -> q + qbar only)
17734
17735         ELSEIF(ISUB.EQ.58) THEN
17736 C...gamma + gamma -> f + fbar
17737           CALL PYWIDT(22,SH,WDTP,WDTE)
17738           WDTESU=0D0
17739           DO 770 I=1,MIN(12,MDCY(22,3))
17740             IF(I.LE.8) EF= KCHG(I,1)/3D0
17741             IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
17742             WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
17743      &      WDTE(I,4))
17744   770     CONTINUE
17745           FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
17746           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
17747             NCHN=NCHN+1
17748             ISIG(NCHN,1)=22
17749             ISIG(NCHN,2)=22
17750             ISIG(NCHN,3)=1
17751             SIGH(NCHN)=FACFF
17752           ENDIF
17753
17754         ELSEIF(ISUB.EQ.59) THEN
17755 C...gamma + Z0 -> f + fbar
17756
17757         ELSEIF(ISUB.EQ.60) THEN
17758 C...gamma + W+/- -> f + fbar'
17759         ENDIF
17760
17761       ELSEIF(ISUB.LE.70) THEN
17762         IF(ISUB.EQ.61) THEN
17763 C...gamma + h0 -> f + fbar
17764
17765         ELSEIF(ISUB.EQ.62) THEN
17766 C...Z0 + Z0 -> f + fbar
17767
17768         ELSEIF(ISUB.EQ.63) THEN
17769 C...Z0 + W+/- -> f + fbar'
17770
17771         ELSEIF(ISUB.EQ.64) THEN
17772 C...Z0 + h0 -> f + fbar
17773
17774         ELSEIF(ISUB.EQ.65) THEN
17775 C...W+ + W- -> f + fbar
17776
17777         ELSEIF(ISUB.EQ.66) THEN
17778 C...W+/- + h0 -> f + fbar'
17779
17780         ELSEIF(ISUB.EQ.67) THEN
17781 C...h0 + h0 -> f + fbar
17782
17783         ELSEIF(ISUB.EQ.68) THEN
17784 C...g + g -> g + g
17785           FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
17786      &    TH2/SH2)*FACA
17787           FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
17788      &    SH2/UH2)*FACA
17789           FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
17790      &    UH2/TH2)
17791           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780
17792           NCHN=NCHN+1
17793           ISIG(NCHN,1)=21
17794           ISIG(NCHN,2)=21
17795           ISIG(NCHN,3)=1
17796           SIGH(NCHN)=0.5D0*FACGG1
17797           NCHN=NCHN+1
17798           ISIG(NCHN,1)=21
17799           ISIG(NCHN,2)=21
17800           ISIG(NCHN,3)=2
17801           SIGH(NCHN)=0.5D0*FACGG2
17802           NCHN=NCHN+1
17803           ISIG(NCHN,1)=21
17804           ISIG(NCHN,2)=21
17805           ISIG(NCHN,3)=3
17806           SIGH(NCHN)=0.5D0*FACGG3
17807   780     CONTINUE
17808
17809         ELSEIF(ISUB.EQ.69) THEN
17810 C...gamma + gamma -> W+ + W-
17811           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17812           FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
17813           FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
17814      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
17815           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790
17816           NCHN=NCHN+1
17817           ISIG(NCHN,1)=22
17818           ISIG(NCHN,2)=22
17819           ISIG(NCHN,3)=1
17820           SIGH(NCHN)=FACWW
17821   790     CONTINUE
17822
17823         ELSEIF(ISUB.EQ.70) THEN
17824 C...gamma + W+/- -> Z0 + W+/-
17825           SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
17826           FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
17827           FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
17828      &    (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
17829      &    FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
17830           DO 810 KCHW=1,-1,-2
17831             DO 800 ISDE=1,2
17832               IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800
17833               NCHN=NCHN+1
17834               ISIG(NCHN,ISDE)=22
17835               ISIG(NCHN,3-ISDE)=24*KCHW
17836               ISIG(NCHN,3)=1
17837               SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
17838   800       CONTINUE
17839   810     CONTINUE
17840         ENDIF
17841
17842       ELSEIF(ISUB.LE.80) THEN
17843         IF(ISUB.EQ.71) THEN
17844 C...Z0 + Z0 -> Z0 + Z0
17845           IF(SH.LE.4.01D0*SQMZ) GOTO 840
17846
17847           IF(MSTP(46).LE.2) THEN
17848 C...Exact scattering ME:s for on-mass-shell gauge bosons
17849             BE2=1D0-4D0*SQMZ/SH
17850             TH=-0.5D0*SH*BE2*(1D0-CTH)
17851             UH=-0.5D0*SH*BE2*(1D0+CTH)
17852             IF(MAX(TH,UH).GT.-1D0) GOTO 840
17853             SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
17854             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17855             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17856             THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
17857             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17858             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17859             UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
17860             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
17861             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
17862             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17863      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17864             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
17865             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
17866      &      (ASHIM+ATHIM+AUHIM)**2)
17867             IF(MSTP(46).EQ.2) FACZZ=0D0
17868
17869           ELSE
17870 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17871             FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17872      &      ABS(A00U+2.*A20U)**2
17873           ENDIF
17874           FACZZ=FACZZ*WIDS(23,1)
17875
17876           DO 830 I=MMIN1,MMAX1
17877             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830
17878             EI=KCHG(IABS(I),1)/3D0
17879             AI=SIGN(1D0,EI)
17880             VI=AI-4D0*EI*XWV
17881             AVI=AI**2+VI**2
17882             DO 820 J=MMIN2,MMAX2
17883               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820
17884               EJ=KCHG(IABS(J),1)/3D0
17885               AJ=SIGN(1D0,EJ)
17886               VJ=AJ-4D0*EJ*XWV
17887               AVJ=AJ**2+VJ**2
17888               NCHN=NCHN+1
17889               ISIG(NCHN,1)=I
17890               ISIG(NCHN,2)=J
17891               ISIG(NCHN,3)=1
17892               SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
17893   820       CONTINUE
17894   830     CONTINUE
17895   840     CONTINUE
17896
17897         ELSEIF(ISUB.EQ.72) THEN
17898 C...Z0 + Z0 -> W+ + W-
17899           IF(SH.LE.4.01D0*SQMZ) GOTO 870
17900
17901           IF(MSTP(46).LE.2) THEN
17902 C...Exact scattering ME:s for on-mass-shell gauge bosons
17903             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
17904             CTH2=CTH**2
17905             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
17906             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
17907             IF(MAX(TH,UH).GT.-1D0) GOTO 870
17908             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
17909      &      (1D0-2D0*SQMZ/SH)
17910             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
17911             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
17912             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
17913      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17914      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17915      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
17916      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17917             ATWIM=0D0
17918             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
17919      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
17920      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
17921      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
17922      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
17923             AUWIM=0D0
17924             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
17925             A4IM=0D0
17926             FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
17927      &      (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
17928             IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
17929             IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
17930      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
17931             IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
17932      &      (ATWIM+AUWIM+A4IM)**2)
17933
17934           ELSE
17935 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
17936             FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
17937      &      ABS(A00U-A20U)**2
17938           ENDIF
17939           FACWW=FACWW*WIDS(24,1)
17940
17941           DO 860 I=MMIN1,MMAX1
17942             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860
17943             EI=KCHG(IABS(I),1)/3D0
17944             AI=SIGN(1D0,EI)
17945             VI=AI-4D0*EI*XWV
17946             AVI=AI**2+VI**2
17947             DO 850 J=MMIN2,MMAX2
17948               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850
17949               EJ=KCHG(IABS(J),1)/3D0
17950               AJ=SIGN(1D0,EJ)
17951               VJ=AJ-4D0*EJ*XWV
17952               AVJ=AJ**2+VJ**2
17953               NCHN=NCHN+1
17954               ISIG(NCHN,1)=I
17955               ISIG(NCHN,2)=J
17956               ISIG(NCHN,3)=1
17957               SIGH(NCHN)=FACWW*AVI*AVJ
17958   850       CONTINUE
17959   860     CONTINUE
17960   870     CONTINUE
17961
17962         ELSEIF(ISUB.EQ.73) THEN
17963 C...Z0 + W+/- -> Z0 + W+/-
17964           IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900
17965
17966           IF(MSTP(46).LE.2) THEN
17967 C...Exact scattering ME:s for on-mass-shell gauge bosons
17968             BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
17969             EP1=1D0-(SQMZ-SQMW)/SH
17970             EP2=1D0+(SQMZ-SQMW)/SH
17971             TH=-0.5D0*SH*BE2*(1D0-CTH)
17972             UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
17973             IF(MAX(TH,UH).GT.-1D0) GOTO 900
17974             THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
17975             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
17976             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
17977             ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
17978      &      1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
17979      &      2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
17980      &      1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
17981             ASWIM=0D0
17982             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
17983      &      (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
17984      &      (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
17985      &      BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
17986      &      (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
17987      &      1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
17988      &      (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
17989      &      (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
17990      &      (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
17991      &      (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
17992      &      ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
17993      &      (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
17994             AUWIM=0D0
17995             A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
17996      &      2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
17997             A4IM=0D0
17998             FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
17999      &      (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
18000             IF(MSTP(46).LE.0) FACZW=0D0
18001             IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
18002      &      (ATHIM+ASWIM+AUWIM+A4IM)**2)
18003             IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
18004      &      (ASWIM+AUWIM+A4IM)**2)
18005
18006           ELSE
18007 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18008             FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
18009      &      ABS(A20U+3.*A11U*SNGL(CTH))**2
18010           ENDIF
18011           FACZW=FACZW*WIDS(23,2)
18012
18013           DO 890 I=MMIN1,MMAX1
18014             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890
18015             EI=KCHG(IABS(I),1)/3D0
18016             AI=SIGN(1D0,EI)
18017             VI=AI-4D0*EI*XWV
18018             AVI=AI**2+VI**2
18019             KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
18020             DO 880 J=MMIN2,MMAX2
18021               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880
18022               EJ=KCHG(IABS(J),1)/3D0
18023               AJ=SIGN(1D0,EJ)
18024               VJ=AI-4D0*EJ*XWV
18025               AVJ=AJ**2+VJ**2
18026               KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
18027               NCHN=NCHN+1
18028               ISIG(NCHN,1)=I
18029               ISIG(NCHN,2)=J
18030               ISIG(NCHN,3)=1
18031               SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
18032               NCHN=NCHN+1
18033               ISIG(NCHN,1)=I
18034               ISIG(NCHN,2)=J
18035               ISIG(NCHN,3)=2
18036               SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
18037   880       CONTINUE
18038   890     CONTINUE
18039   900     CONTINUE
18040
18041         ELSEIF(ISUB.EQ.75) THEN
18042 C...W+ + W- -> gamma + gamma
18043
18044         ELSEIF(ISUB.EQ.76) THEN
18045 C...W+ + W- -> Z0 + Z0
18046           IF(SH.LE.4.01D0*SQMZ) GOTO 930
18047
18048           IF(MSTP(46).LE.2) THEN
18049 C...Exact scattering ME:s for on-mass-shell gauge bosons
18050             BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
18051             CTH2=CTH**2
18052             TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
18053             UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
18054             IF(MAX(TH,UH).GT.-1D0) GOTO 930
18055             SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
18056      &      (1D0-2D0*SQMZ/SH)
18057             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18058             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18059             ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
18060      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18061      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18062      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
18063      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18064             ATWIM=0D0
18065             AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
18066      &      CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
18067      &      ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
18068      &      (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
18069      &      2D0*(SQMW+SQMZ)/SH*BE2*CTH))
18070             AUWIM=0D0
18071             A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
18072             A4IM=0D0
18073             FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18074      &      (SH/SQMW)**2*SH2
18075             IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
18076             IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
18077      &      (ASHIM+ATWIM+AUWIM+A4IM)**2)
18078             IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
18079      &      (ATWIM+AUWIM+A4IM)**2)
18080
18081           ELSE
18082 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18083             FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18084      &      ABS(A00U-A20U)**2
18085           ENDIF
18086           FACZZ=FACZZ*WIDS(23,1)
18087
18088           DO 920 I=MMIN1,MMAX1
18089             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920
18090             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18091             DO 910 J=MMIN2,MMAX2
18092               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910
18093               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18094               IF(EI*EJ.GT.0D0) GOTO 910
18095               NCHN=NCHN+1
18096               ISIG(NCHN,1)=I
18097               ISIG(NCHN,2)=J
18098               ISIG(NCHN,3)=1
18099               SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
18100   910       CONTINUE
18101   920     CONTINUE
18102   930     CONTINUE
18103
18104         ELSEIF(ISUB.EQ.77) THEN
18105 C...W+/- + W+/- -> W+/- + W+/-
18106           IF(SH.LE.4.01D0*SQMW) GOTO 960
18107
18108           IF(MSTP(46).LE.2) THEN
18109 C...Exact scattering ME:s for on-mass-shell gauge bosons
18110             BE2=1D0-4D0*SQMW/SH
18111             BE4=BE2**2
18112             CTH2=CTH**2
18113             CTH3=CTH**3
18114             TH=-0.5D0*SH*BE2*(1D0-CTH)
18115             UH=-0.5D0*SH*BE2*(1D0+CTH)
18116             IF(MAX(TH,UH).GT.-1D0) GOTO 960
18117             SHANG=(1D0+BE2)**2
18118             ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
18119             ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
18120             THANG=(BE2-CTH)**2
18121             ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
18122             ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
18123             UHANG=(BE2+CTH)**2
18124             AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
18125             AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
18126             SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
18127             ASGRE=XW*SGZANG
18128             ASGIM=0D0
18129             ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
18130             ASZIM=0D0
18131             TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
18132      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
18133             ATGRE=0.5D0*XW*SH/TH*TGZANG
18134             ATGIM=0D0
18135             ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
18136             ATZIM=0D0
18137             UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
18138      &      BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
18139             AUGRE=0.5D0*XW*SH/UH*UGZANG
18140             AUGIM=0D0
18141             AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
18142             AUZIM=0D0
18143             A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
18144             A4AIM=0D0
18145             A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
18146             A4SIM=0D0
18147             FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
18148      &      (SH/SQMW)**2*SH2
18149             IF(MSTP(46).LE.0) THEN
18150               AWWARE=ASHRE
18151               AWWAIM=ASHIM
18152               AWWSRE=0D0
18153               AWWSIM=0D0
18154             ELSEIF(MSTP(46).EQ.1) THEN
18155               AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18156               AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18157               AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18158               AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18159             ELSE
18160               AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
18161               AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
18162               AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
18163               AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
18164             ENDIF
18165             AWWA2=AWWARE**2+AWWAIM**2
18166             AWWS2=AWWSRE**2+AWWSIM**2
18167
18168           ELSE
18169 C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
18170             FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
18171      &      ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2
18172             FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
18173           ENDIF
18174
18175           DO 950 I=MMIN1,MMAX1
18176             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950
18177             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
18178             DO 940 J=MMIN2,MMAX2
18179               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940
18180               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
18181               IF(EI*EJ.LT.0D0) THEN
18182 C...W+W-
18183                 IF(MSTP(45).EQ.1) GOTO 940
18184                 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
18185                 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
18186               ELSE
18187 C...W+W+/W-W-
18188                 IF(MSTP(45).EQ.2) GOTO 940
18189                 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
18190                 IF(MSTP(46).GE.3) FACWW=FWWS
18191                 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
18192                 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
18193               ENDIF
18194               NCHN=NCHN+1
18195               ISIG(NCHN,1)=I
18196               ISIG(NCHN,2)=J
18197               ISIG(NCHN,3)=1
18198               SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
18199               IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
18200   940       CONTINUE
18201   950     CONTINUE
18202   960     CONTINUE
18203
18204         ELSEIF(ISUB.EQ.78) THEN
18205 C...W+/- + h0 -> W+/- + h0
18206
18207         ELSEIF(ISUB.EQ.79) THEN
18208 C...h0 + h0 -> h0 + h0
18209
18210         ELSEIF(ISUB.EQ.80) THEN
18211 C...q + gamma -> q' + pi+/-
18212           FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
18213           ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
18214           Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
18215           DELSH=UH*SQRT(ASSH*Q2FPSH)
18216           ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
18217           Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
18218           DELUH=SH*SQRT(ASUH*Q2FPUH)
18219           DO 980 I=MAX(-2,MMINA),MIN(2,MMAXA)
18220             IF(I.EQ.0) GOTO 980
18221             EI=KCHG(IABS(I),1)/3D0
18222             EJ=SIGN(1D0-ABS(EI),EI)
18223             DO 970 ISDE=1,2
18224               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970
18225               IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970
18226               NCHN=NCHN+1
18227               ISIG(NCHN,ISDE)=I
18228               ISIG(NCHN,3-ISDE)=22
18229               ISIG(NCHN,3)=1
18230               SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
18231   970       CONTINUE
18232   980     CONTINUE
18233
18234         ENDIF
18235
18236 C...C: 2 -> 2, tree diagrams with masses
18237
18238       ELSEIF(ISUB.LE.90) THEN
18239         IF(ISUB.EQ.81) THEN
18240 C...q + qbar -> Q + Qbar
18241           FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+
18242      &    (UH-SQM3)**2)/SH2+2D0*SQM3/SH)
18243           IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,0D0)
18244           WID2=1D0
18245           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18246           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18247           FACQQB=FACQQB*WID2
18248           DO 990 I=MMINA,MMAXA
18249             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18250      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990
18251             NCHN=NCHN+1
18252             ISIG(NCHN,1)=I
18253             ISIG(NCHN,2)=-I
18254             ISIG(NCHN,3)=1
18255             SIGH(NCHN)=FACQQB
18256   990     CONTINUE
18257
18258         ELSEIF(ISUB.EQ.82) THEN
18259 C...g + g -> Q + Qbar
18260           IF(MSTP(34).EQ.0) THEN
18261             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18262      &      2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18263      &      (TH-SQM3)**2)
18264             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18265      &      2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18266      &      (UH-SQM3)**2)
18267           ELSE
18268             FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)-
18269      &      2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18270      &      (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/
18271      &      (SH*(TH-SQM3)))
18272             FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)-
18273      &      2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/
18274      &      (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/
18275      &      (SH*(UH-SQM3)))
18276           ENDIF
18277           IF(MSTP(35).GE.1) THEN
18278             FATRE=PYHFTH(SH,SQM3,2D0/7D0)
18279             FACQQ1=FACQQ1*FATRE
18280             FACQQ2=FACQQ2*FATRE
18281           ENDIF
18282           WID2=1D0
18283           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18284           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18285           FACQQ1=FACQQ1*WID2
18286           FACQQ2=FACQQ2*WID2
18287           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1000
18288           NCHN=NCHN+1
18289           ISIG(NCHN,1)=21
18290           ISIG(NCHN,2)=21
18291           ISIG(NCHN,3)=1
18292           SIGH(NCHN)=FACQQ1
18293           NCHN=NCHN+1
18294           ISIG(NCHN,1)=21
18295           ISIG(NCHN,2)=21
18296           ISIG(NCHN,3)=2
18297           SIGH(NCHN)=FACQQ2
18298  1000     CONTINUE
18299
18300         ELSEIF(ISUB.EQ.83) THEN
18301 C...f + q -> f' + Q
18302           FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
18303           FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
18304           DO 1020 I=MMIN1,MMAX1
18305             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020
18306             DO 1010 J=MMIN2,MMAX2
18307               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010
18308               IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010
18309               IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010
18310               IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
18311      &        THEN
18312                 NCHN=NCHN+1
18313                 ISIG(NCHN,1)=I
18314                 ISIG(NCHN,2)=J
18315                 ISIG(NCHN,3)=1
18316                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18317      &          (IABS(I)+1)/2)*VINT(180+J)
18318                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
18319      &          (MINT(55)+1)/2)*VINT(180+J)
18320                 WID2=1D0
18321                 IF(I.GT.0) THEN
18322                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18323                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18324      &            WIDS(MINT(55),2)
18325                 ELSE
18326                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18327                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18328      &            WIDS(MINT(55),3)
18329                 ENDIF
18330                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18331                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18332               ENDIF
18333               IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
18334      &        THEN
18335                 NCHN=NCHN+1
18336                 ISIG(NCHN,1)=I
18337                 ISIG(NCHN,2)=J
18338                 ISIG(NCHN,3)=2
18339                 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
18340      &          (IABS(J)+1)/2)*VINT(180+I)
18341                 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
18342      &          (MINT(55)+1)/2)*VINT(180+I)
18343                 IF(J.GT.0) THEN
18344                   IF(MINT(55).EQ.6) WID2=WIDS(6,2)
18345                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18346      &            WIDS(MINT(55),2)
18347                 ELSE
18348                   IF(MINT(55).EQ.6) WID2=WIDS(6,3)
18349                   IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
18350      &            WIDS(MINT(55),3)
18351                 ENDIF
18352                 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
18353                 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
18354               ENDIF
18355  1010       CONTINUE
18356  1020     CONTINUE
18357
18358         ELSEIF(ISUB.EQ.84) THEN
18359 C...g + gamma -> Q + Qbar
18360           FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18361           FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
18362      &    ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18363           IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0)
18364           WID2=1D0
18365           IF(MINT(55).EQ.6) WID2=WIDS(6,1)
18366           IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
18367           FACQQ=FACQQ*WID2
18368           IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18369             NCHN=NCHN+1
18370             ISIG(NCHN,1)=21
18371             ISIG(NCHN,2)=22
18372             ISIG(NCHN,3)=1
18373             SIGH(NCHN)=FACQQ
18374           ENDIF
18375           IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18376             NCHN=NCHN+1
18377             ISIG(NCHN,1)=22
18378             ISIG(NCHN,2)=21
18379             ISIG(NCHN,3)=1
18380             SIGH(NCHN)=FACQQ
18381           ENDIF
18382
18383         ELSEIF(ISUB.EQ.85) THEN
18384 C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
18385           FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH)
18386           FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
18387      &    ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU))
18388           IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
18389           IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
18390      &    FACFF=FACFF*PYHFTH(SH,SQM3,1D0)
18391           WID2=1D0
18392           IF(MINT(56).EQ.6) WID2=WIDS(6,1)
18393           IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
18394           IF(MINT(56).EQ.17) WID2=WIDS(17,1)
18395           FACFF=FACFF*WID2
18396           IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18397             NCHN=NCHN+1
18398             ISIG(NCHN,1)=22
18399             ISIG(NCHN,2)=22
18400             ISIG(NCHN,3)=1
18401             SIGH(NCHN)=FACFF
18402           ENDIF
18403
18404         ELSEIF(ISUB.EQ.86) THEN
18405 C...g + g -> J/Psi + g
18406           FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
18407      &    (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18408      &    ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18409           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18410             NCHN=NCHN+1
18411             ISIG(NCHN,1)=21
18412             ISIG(NCHN,2)=21
18413             ISIG(NCHN,3)=1
18414             SIGH(NCHN)=FACQQG
18415           ENDIF
18416
18417         ELSEIF(ISUB.EQ.87) THEN
18418 C...g + g -> chi_0c + g
18419           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18420           QGTW=(SH*TH*UH)/SH**3
18421           RGTW=SQM3/SH
18422           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18423      &    (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18424      &    6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
18425      &    PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
18426      &    2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
18427      &    (QGTW*(QGTW-RGTW*PGTW)**4)
18428           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18429             NCHN=NCHN+1
18430             ISIG(NCHN,1)=21
18431             ISIG(NCHN,2)=21
18432             ISIG(NCHN,3)=1
18433             SIGH(NCHN)=FACQQG
18434           ENDIF
18435
18436         ELSEIF(ISUB.EQ.88) THEN
18437 C...g + g -> chi_1c + g
18438           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18439           QGTW=(SH*TH*UH)/SH**3
18440           RGTW=SQM3/SH
18441           FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18442      &    PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
18443      &    5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
18444      &    (QGTW-RGTW*PGTW)**4
18445           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18446             NCHN=NCHN+1
18447             ISIG(NCHN,1)=21
18448             ISIG(NCHN,2)=21
18449             ISIG(NCHN,3)=1
18450             SIGH(NCHN)=FACQQG
18451           ENDIF
18452
18453         ELSEIF(ISUB.EQ.89) THEN
18454 C...g + g -> chi_2c + g
18455           PGTW=(SH*TH+TH*UH+UH*SH)/SH2
18456           QGTW=(SH*TH*UH)/SH**3
18457           RGTW=SQM3/SH
18458           FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
18459      &    (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
18460      &    3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
18461      &    2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
18462      &    RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
18463      &    QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
18464           IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18465             NCHN=NCHN+1
18466             ISIG(NCHN,1)=21
18467             ISIG(NCHN,2)=21
18468             ISIG(NCHN,3)=1
18469             SIGH(NCHN)=FACQQG
18470           ENDIF
18471         ENDIF
18472
18473 C...D: Mimimum bias processes
18474
18475       ELSEIF(ISUB.LE.100) THEN
18476         IF(ISUB.EQ.91) THEN
18477 C...Elastic scattering
18478           SIGS=SIGT(0,0,1)
18479
18480         ELSEIF(ISUB.EQ.92) THEN
18481 C...Single diffractive scattering (first side, i.e. XB)
18482           SIGS=SIGT(0,0,2)
18483
18484         ELSEIF(ISUB.EQ.93) THEN
18485 C...Single diffractive scattering (second side, i.e. AX)
18486           SIGS=SIGT(0,0,3)
18487
18488         ELSEIF(ISUB.EQ.94) THEN
18489 C...Double diffractive scattering
18490           SIGS=SIGT(0,0,4)
18491
18492         ELSEIF(ISUB.EQ.95) THEN
18493 C...Low-pT scattering
18494           SIGS=SIGT(0,0,5)
18495
18496         ELSEIF(ISUB.EQ.96) THEN
18497 C...Multiple interactions: sum of QCD processes
18498           CALL PYWIDT(21,SH,WDTP,WDTE)
18499
18500 C...q + q' -> q + q'
18501           FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
18502           FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
18503      &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
18504           FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
18505      &    MSTP(34)*2D0/3D0*SH2/(TH*UH))
18506           DO 1040 I=-3,3
18507             IF(I.EQ.0) GOTO 1040
18508             DO 1030 J=-3,3
18509               IF(J.EQ.0) GOTO 1030
18510               NCHN=NCHN+1
18511               ISIG(NCHN,1)=I
18512               ISIG(NCHN,2)=J
18513               ISIG(NCHN,3)=111
18514               SIGH(NCHN)=FACQQ1
18515               IF(I.EQ.-J) SIGH(NCHN)=FACQQB
18516               IF(I.EQ.J) THEN
18517                 SIGH(NCHN)=0.5D0*SIGH(NCHN)
18518                 NCHN=NCHN+1
18519                 ISIG(NCHN,1)=I
18520                 ISIG(NCHN,2)=J
18521                 ISIG(NCHN,3)=112
18522                 SIGH(NCHN)=0.5D0*FACQQ2
18523               ENDIF
18524  1030       CONTINUE
18525  1040     CONTINUE
18526
18527 C...q + qbar -> q' + qbar' or g + g
18528           FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
18529      &    (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
18530           FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18531      &    UH2/SH2)
18532           FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18533      &    TH2/SH2)
18534           DO 1050 I=-3,3
18535             IF(I.EQ.0) GOTO 1050
18536             NCHN=NCHN+1
18537             ISIG(NCHN,1)=I
18538             ISIG(NCHN,2)=-I
18539             ISIG(NCHN,3)=121
18540             SIGH(NCHN)=FACQQB
18541             NCHN=NCHN+1
18542             ISIG(NCHN,1)=I
18543             ISIG(NCHN,2)=-I
18544             ISIG(NCHN,3)=131
18545             SIGH(NCHN)=0.5D0*FACGG1
18546             NCHN=NCHN+1
18547             ISIG(NCHN,1)=I
18548             ISIG(NCHN,2)=-I
18549             ISIG(NCHN,3)=132
18550             SIGH(NCHN)=0.5D0*FACGG2
18551  1050     CONTINUE
18552
18553 C...q + g -> q + g
18554           FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
18555      &    UH/SH)*FACA
18556           FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
18557      &    SH/UH)
18558           DO 1070 I=-3,3
18559             IF(I.EQ.0) GOTO 1070
18560             DO 1060 ISDE=1,2
18561               NCHN=NCHN+1
18562               ISIG(NCHN,ISDE)=I
18563               ISIG(NCHN,3-ISDE)=21
18564               ISIG(NCHN,3)=281
18565               SIGH(NCHN)=FACQG1
18566               NCHN=NCHN+1
18567               ISIG(NCHN,ISDE)=I
18568               ISIG(NCHN,3-ISDE)=21
18569               ISIG(NCHN,3)=282
18570               SIGH(NCHN)=FACQG2
18571  1060       CONTINUE
18572  1070     CONTINUE
18573
18574 C...g + g -> q + qbar or g + g
18575           FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
18576      &    UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18577           FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
18578      &    TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA
18579           FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
18580      &    2D0*TH/SH+TH2/SH2)*FACA
18581           FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
18582      &    2D0*SH/UH+SH2/UH2)*FACA
18583           FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
18584      &    2D0*UH/TH+UH2/TH2)
18585           NCHN=NCHN+1
18586           ISIG(NCHN,1)=21
18587           ISIG(NCHN,2)=21
18588           ISIG(NCHN,3)=531
18589           SIGH(NCHN)=FACQQ1
18590           NCHN=NCHN+1
18591           ISIG(NCHN,1)=21
18592           ISIG(NCHN,2)=21
18593           ISIG(NCHN,3)=532
18594           SIGH(NCHN)=FACQQ2
18595           NCHN=NCHN+1
18596           ISIG(NCHN,1)=21
18597           ISIG(NCHN,2)=21
18598           ISIG(NCHN,3)=681
18599           SIGH(NCHN)=0.5D0*FACGG1
18600           NCHN=NCHN+1
18601           ISIG(NCHN,1)=21
18602           ISIG(NCHN,2)=21
18603           ISIG(NCHN,3)=682
18604           SIGH(NCHN)=0.5D0*FACGG2
18605           NCHN=NCHN+1
18606           ISIG(NCHN,1)=21
18607           ISIG(NCHN,2)=21
18608           ISIG(NCHN,3)=683
18609           SIGH(NCHN)=0.5D0*FACGG3
18610         ENDIF
18611
18612 C...E: 2 -> 1, loop diagrams
18613
18614       ELSEIF(ISUB.LE.110) THEN
18615         IF(ISUB.EQ.101) THEN
18616 C...g + g -> gamma*/Z0
18617
18618         ELSEIF(ISUB.EQ.102) THEN
18619 C...g + g -> h0 (or H0, or A0)
18620           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18621           HS=SHR*WDTP(0)
18622           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18623           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18624           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18625      &    FACBW=0D0
18626           HI=SHR*WDTP(13)/32D0
18627           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080
18628           NCHN=NCHN+1
18629           ISIG(NCHN,1)=21
18630           ISIG(NCHN,2)=21
18631           ISIG(NCHN,3)=1
18632           SIGH(NCHN)=HI*FACBW*HF
18633  1080     CONTINUE
18634
18635         ELSEIF(ISUB.EQ.103) THEN
18636 C...gamma + gamma -> h0 (or H0, or A0)
18637           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
18638           HS=SHR*WDTP(0)
18639           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
18640           FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
18641           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
18642      &    FACBW=0D0
18643           HI=SHR*WDTP(14)*2D0
18644           IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090
18645           NCHN=NCHN+1
18646           ISIG(NCHN,1)=22
18647           ISIG(NCHN,2)=22
18648           ISIG(NCHN,3)=1
18649           SIGH(NCHN)=HI*FACBW*HF
18650  1090     CONTINUE
18651
18652 C...Continuation C: 2 -> 2, tree diagrams with masses.
18653
18654       ELSEIF(ISUB.EQ.106) THEN
18655 C...g + g -> J/Psi + gamma.
18656         EQ=2D0/3D0
18657         FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
18658      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18659      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18660         IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
18661           NCHN=NCHN+1
18662           ISIG(NCHN,1)=21
18663           ISIG(NCHN,2)=21
18664           ISIG(NCHN,3)=1
18665           SIGH(NCHN)=FACQQG
18666         ENDIF
18667
18668       ELSEIF(ISUB.EQ.107) THEN
18669 C...g + gamma -> J/Psi + g.
18670         EQ=2D0/3D0
18671         FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
18672      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18673      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18674         IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
18675           NCHN=NCHN+1
18676           ISIG(NCHN,1)=21
18677           ISIG(NCHN,2)=22
18678           ISIG(NCHN,3)=1
18679           SIGH(NCHN)=FACQQG
18680         ENDIF
18681         IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
18682           NCHN=NCHN+1
18683           ISIG(NCHN,1)=22
18684           ISIG(NCHN,2)=21
18685           ISIG(NCHN,3)=1
18686           SIGH(NCHN)=FACQQG
18687         ENDIF
18688
18689       ELSEIF(ISUB.EQ.108) THEN
18690 C...gamma + gamma -> J/Psi + gamma.
18691         EQ=2D0/3D0
18692         FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
18693      &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
18694      &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
18695         IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
18696           NCHN=NCHN+1
18697           ISIG(NCHN,1)=22
18698           ISIG(NCHN,2)=22
18699           ISIG(NCHN,3)=1
18700           SIGH(NCHN)=FACQQG
18701         ENDIF
18702
18703 C...F: 2 -> 2, box diagrams
18704
18705         ELSEIF(ISUB.EQ.110) THEN
18706 C...f + fbar -> gamma + h0
18707           THUH=MAX(TH*UH,SH*CKIN(3)**2)
18708           FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
18709           FACHG=FACHG*WIDS(KFHIGG,2)
18710 C...Calculate loop contributions for intermediate gamma* and Z0
18711           CIGTOT=CMPLX(0.,0.)
18712           CIZTOT=CMPLX(0.,0.)
18713           JMAX=3*MSTP(1)+1
18714           DO 1100 J=1,JMAX
18715             IF(J.LE.2*MSTP(1)) THEN
18716               FNC=1D0
18717               EJ=KCHG(J,1)/3D0
18718               AJ=SIGN(1D0,EJ+0.1D0)
18719               VJ=AJ-4D0*EJ*XWV
18720               BALP=SQM4/(2D0*PMAS(J,1))**2
18721               BBET=SH/(2D0*PMAS(J,1))**2
18722             ELSEIF(J.LE.3*MSTP(1)) THEN
18723               FNC=3D0
18724               JL=2*(J-2*MSTP(1))-1
18725               EJ=KCHG(10+JL,1)/3D0
18726               AJ=SIGN(1D0,EJ+0.1D0)
18727               VJ=AJ-4D0*EJ*XWV
18728               BALP=SQM4/(2D0*PMAS(10+JL,1))**2
18729               BBET=SH/(2D0*PMAS(10+JL,1))**2
18730             ELSE
18731               BALP=SQM4/(2D0*PMAS(24,1))**2
18732               BBET=SH/(2D0*PMAS(24,1))**2
18733             ENDIF
18734             BABI=1D0/(BALP-BBET)
18735             IF(BALP.LT.1D0) THEN
18736               F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.)
18737               F1ALP=F0ALP**2
18738             ELSE
18739               F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
18740      &        -SNGL(0.5D0*PARU(1)))
18741               F1ALP=-F0ALP**2
18742             ENDIF
18743             F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
18744             IF(BBET.LT.1D0) THEN
18745               F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.)
18746               F1BET=F0BET**2
18747             ELSE
18748               F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
18749      &        -SNGL(0.5D0*PARU(1)))
18750               F1BET=-F0BET**2
18751             ENDIF
18752             F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET
18753             IF(J.LE.3*MSTP(1)) THEN
18754               FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+
18755      &        BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP))
18756               CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF
18757               CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF
18758             ELSE
18759               TXW=XW/XW1
18760               CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)*
18761      &        (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
18762      &        SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
18763               CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP*
18764      &        (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+
18765      &        SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
18766      &        (F1BET-F1ALP))
18767             ENDIF
18768  1100     CONTINUE
18769           CIGTOT=CIGTOT/SNGL(SH)
18770           CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ))
18771 C...Loop over initial flavours
18772           DO 1110 I=MMINA,MMAXA
18773             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110
18774             EI=KCHG(IABS(I),1)/3D0
18775             AI=SIGN(1D0,EI)
18776             VI=AI-4D0*EI*XWV
18777             FCOI=1D0
18778             IF(IABS(I).LE.10) FCOI=FACA/3D0
18779             NCHN=NCHN+1
18780             ISIG(NCHN,1)=I
18781             ISIG(NCHN,2)=-I
18782             ISIG(NCHN,3)=1
18783             SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)*
18784      &      CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
18785  1110     CONTINUE
18786
18787         ENDIF
18788
18789       ELSEIF(ISUB.LE.120) THEN
18790         IF(ISUB.EQ.111) THEN
18791 C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
18792           A5STUR=0D0
18793           A5STUI=0D0
18794           DO 1120 I=1,2*MSTP(1)
18795             SQMQ=PMAS(I,1)**2
18796             EPSS=4D0*SQMQ/SH
18797             EPSH=4D0*SQMQ/SQMH
18798             CALL PYWAUX(1,EPSS,W1SR,W1SI)
18799             CALL PYWAUX(1,EPSH,W1HR,W1HI)
18800             CALL PYWAUX(2,EPSS,W2SR,W2SI)
18801             CALL PYWAUX(2,EPSH,W2HR,W2HI)
18802             A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
18803      &      (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
18804             A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
18805      &      (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
18806  1120     CONTINUE
18807           FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18808      &    SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
18809           FACGH=FACGH*WIDS(25,2)
18810           DO 1130 I=MMINA,MMAXA
18811             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
18812      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130
18813             NCHN=NCHN+1
18814             ISIG(NCHN,1)=I
18815             ISIG(NCHN,2)=-I
18816             ISIG(NCHN,3)=1
18817             SIGH(NCHN)=FACGH
18818  1130     CONTINUE
18819
18820         ELSEIF(ISUB.EQ.112) THEN
18821 C...f + g -> f + h0 (q + g -> q + h0 only)
18822           A5TSUR=0D0
18823           A5TSUI=0D0
18824           DO 1140 I=1,2*MSTP(1)
18825             SQMQ=PMAS(I,1)**2
18826             EPST=4D0*SQMQ/TH
18827             EPSH=4D0*SQMQ/SQMH
18828             CALL PYWAUX(1,EPST,W1TR,W1TI)
18829             CALL PYWAUX(1,EPSH,W1HR,W1HI)
18830             CALL PYWAUX(2,EPST,W2TR,W2TI)
18831             CALL PYWAUX(2,EPSH,W2HR,W2HI)
18832             A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
18833      &      (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
18834             A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
18835      &      (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
18836  1140     CONTINUE
18837           FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
18838      &    SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
18839           FACQH=FACQH*WIDS(25,2)
18840           DO 1160 I=MMINA,MMAXA
18841             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160
18842             DO 1150 ISDE=1,2
18843               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150
18844               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150
18845               NCHN=NCHN+1
18846               ISIG(NCHN,ISDE)=I
18847               ISIG(NCHN,3-ISDE)=21
18848               ISIG(NCHN,3)=1
18849               SIGH(NCHN)=FACQH
18850  1150       CONTINUE
18851  1160     CONTINUE
18852
18853         ELSEIF(ISUB.EQ.113) THEN
18854 C...g + g -> g + h0
18855           A2STUR=0D0
18856           A2STUI=0D0
18857           A2USTR=0D0
18858           A2USTI=0D0
18859           A2TUSR=0D0
18860           A2TUSI=0D0
18861           A4STUR=0D0
18862           A4STUI=0D0
18863           DO 1170 I=1,2*MSTP(1)
18864             SQMQ=PMAS(I,1)**2
18865             EPSS=4D0*SQMQ/SH
18866             EPST=4D0*SQMQ/TH
18867             EPSU=4D0*SQMQ/UH
18868             EPSH=4D0*SQMQ/SQMH
18869             IF(EPSH.LT.1.D-6) GOTO 1170
18870             CALL PYWAUX(1,EPSS,W1SR,W1SI)
18871             CALL PYWAUX(1,EPST,W1TR,W1TI)
18872             CALL PYWAUX(1,EPSU,W1UR,W1UI)
18873             CALL PYWAUX(1,EPSH,W1HR,W1HI)
18874             CALL PYWAUX(2,EPSS,W2SR,W2SI)
18875             CALL PYWAUX(2,EPST,W2TR,W2TI)
18876             CALL PYWAUX(2,EPSU,W2UR,W2UI)
18877             CALL PYWAUX(2,EPSH,W2HR,W2HI)
18878             CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
18879             CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
18880             CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
18881             CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
18882             CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
18883             CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
18884             CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
18885             CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
18886             CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
18887             CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
18888             CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
18889             CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
18890             W3STUR=YHSTUR-Y3STUR-Y3UTSR
18891             W3STUI=YHSTUI-Y3STUI-Y3UTSI
18892             W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
18893             W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
18894             W3TSUR=YHTSUR-Y3TSUR-Y3USTR
18895             W3TSUI=YHTSUI-Y3TSUI-Y3USTI
18896             W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
18897             W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
18898             W3USTR=YHUSTR-Y3USTR-Y3TSUR
18899             W3USTI=YHUSTI-Y3USTI-Y3TSUI
18900             W3UTSR=YHUTSR-Y3UTSR-Y3STUR
18901             W3UTSI=YHUTSI-Y3UTSI-Y3STUI
18902             B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
18903      &      (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
18904      &      (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
18905      &      (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
18906      &      (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
18907             B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
18908      &      (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
18909      &      W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
18910      &      (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
18911      &      (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
18912             B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
18913      &      (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
18914      &      (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
18915      &      (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
18916      &      (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
18917             B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
18918      &      (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
18919      &      W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
18920      &      (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
18921      &      (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
18922             B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
18923      &      (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
18924      &      (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
18925      &      (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
18926      &      (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
18927             B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
18928      &      (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
18929      &      W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
18930      &      (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
18931      &      (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
18932             B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
18933      &      (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
18934      &      (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
18935      &      (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
18936      &      (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
18937             B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
18938      &      (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
18939      &      W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
18940      &      (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
18941      &      (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
18942             B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
18943      &      (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
18944      &      (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
18945      &      (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
18946      &      (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
18947             B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
18948      &      (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
18949      &      W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
18950      &      (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
18951      &      (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
18952             B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
18953      &      (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
18954      &      (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
18955      &      (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
18956      &      (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
18957             B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
18958      &      (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
18959      &      W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
18960      &      (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
18961      &      (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
18962             B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18963      &      (W2SR-W2HR+W3STUR))
18964             B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
18965             B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18966      &      (W2TR-W2HR+W3TUSR))
18967             B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
18968             B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
18969      &      (W2UR-W2HR+W3USTR))
18970             B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
18971             A2STUR=A2STUR+B2STUR+B2SUTR
18972             A2STUI=A2STUI+B2STUI+B2SUTI
18973             A2USTR=A2USTR+B2USTR+B2UTSR
18974             A2USTI=A2USTI+B2USTI+B2UTSI
18975             A2TUSR=A2TUSR+B2TUSR+B2TSUR
18976             A2TUSI=A2TUSI+B2TUSI+B2TSUI
18977             A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
18978             A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
18979  1170     CONTINUE
18980           FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
18981      &    SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
18982      &    A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
18983           FACGH=FACGH*WIDS(25,2)
18984           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180
18985           NCHN=NCHN+1
18986           ISIG(NCHN,1)=21
18987           ISIG(NCHN,2)=21
18988           ISIG(NCHN,3)=1
18989           SIGH(NCHN)=FACGH
18990  1180     CONTINUE
18991
18992         ELSEIF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
18993 C...g + g -> gamma + gamma or g + g -> g + gamma
18994           A0STUR=0D0
18995           A0STUI=0D0
18996           A0TSUR=0D0
18997           A0TSUI=0D0
18998           A0UTSR=0D0
18999           A0UTSI=0D0
19000           A1STUR=0D0
19001           A1STUI=0D0
19002           A2STUR=0D0
19003           A2STUI=0D0
19004           ALST=LOG(-SH/TH)
19005           ALSU=LOG(-SH/UH)
19006           ALTU=LOG(TH/UH)
19007           IMAX=2*MSTP(1)
19008           IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
19009           DO 1190 I=1,IMAX
19010             EI=KCHG(IABS(I),1)/3D0
19011             EIWT=EI**2
19012             IF(ISUB.EQ.115) EIWT=EI
19013             SQMQ=PMAS(I,1)**2
19014             EPSS=4D0*SQMQ/SH
19015             EPST=4D0*SQMQ/TH
19016             EPSU=4D0*SQMQ/UH
19017             IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1.D-4) THEN
19018               B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
19019      &        PARU(1)**2)
19020               B0STUI=0D0
19021               B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
19022               B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
19023               B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
19024               B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
19025               B1STUR=-1D0
19026               B1STUI=0D0
19027               B2STUR=-1D0
19028               B2STUI=0D0
19029             ELSE
19030               CALL PYWAUX(1,EPSS,W1SR,W1SI)
19031               CALL PYWAUX(1,EPST,W1TR,W1TI)
19032               CALL PYWAUX(1,EPSU,W1UR,W1UI)
19033               CALL PYWAUX(2,EPSS,W2SR,W2SI)
19034               CALL PYWAUX(2,EPST,W2TR,W2TI)
19035               CALL PYWAUX(2,EPSU,W2UR,W2UI)
19036               CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
19037               CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
19038               CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
19039               CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
19040               CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
19041               CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
19042               B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
19043      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
19044      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
19045      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
19046      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19047      &        0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19048               B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
19049      &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
19050      &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
19051      &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
19052      &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
19053      &        0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19054               B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
19055      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
19056      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
19057      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
19058      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19059      &        0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
19060               B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
19061      &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
19062      &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
19063      &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
19064      &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
19065      &        0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
19066               B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
19067      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
19068      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
19069      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
19070      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19071      &        0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
19072               B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
19073      &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
19074      &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
19075      &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
19076      &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
19077      &        0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
19078               B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
19079      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
19080      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
19081      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
19082               B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
19083      &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
19084      &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
19085      &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
19086               B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
19087      &        0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
19088      &        0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
19089               B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
19090      &        0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
19091      &        0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
19092             ENDIF
19093             A0STUR=A0STUR+EIWT*B0STUR
19094             A0STUI=A0STUI+EIWT*B0STUI
19095             A0TSUR=A0TSUR+EIWT*B0TSUR
19096             A0TSUI=A0TSUI+EIWT*B0TSUI
19097             A0UTSR=A0UTSR+EIWT*B0UTSR
19098             A0UTSI=A0UTSI+EIWT*B0UTSI
19099             A1STUR=A1STUR+EIWT*B1STUR
19100             A1STUI=A1STUI+EIWT*B1STUI
19101             A2STUR=A2STUR+EIWT*B2STUR
19102             A2STUI=A2STUI+EIWT*B2STUI
19103  1190     CONTINUE
19104           ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
19105      &    A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
19106           FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
19107           FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
19108           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1200
19109           NCHN=NCHN+1
19110           ISIG(NCHN,1)=21
19111           ISIG(NCHN,2)=21
19112           ISIG(NCHN,3)=1
19113           IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
19114           IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
19115  1200     CONTINUE
19116
19117         ELSEIF(ISUB.EQ.116) THEN
19118 C...g + g -> gamma + Z0
19119
19120         ELSEIF(ISUB.EQ.117) THEN
19121 C...g + g -> Z0 + Z0
19122
19123         ELSEIF(ISUB.EQ.118) THEN
19124 C...g + g -> W+ + W-
19125
19126         ENDIF
19127
19128 C...G: 2 -> 3, tree diagrams
19129
19130       ELSEIF(ISUB.LE.140) THEN
19131         IF(ISUB.EQ.121) THEN
19132 C...g + g -> Q + Qbar + h0
19133           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210
19134           IA=KFPR(ISUBSV,2)
19135           PMF=PMAS(IA,1)
19136           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19137      &    (0.5D0*PMF/PMAS(24,1))**2
19138           IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19139      &    FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19140      &    LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19141           WID2=1D0
19142           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19143           FACQQH=FACQQH*WID2
19144           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19145             IKFI=1
19146             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19147             IF(IA.GT.10) IKFI=3
19148             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19149           ENDIF
19150           CALL PYQQBH(WTQQBH)
19151           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19152           HS=SHR*WDTP(0)
19153           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19154           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19155           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19156      &    FACBW=0D0
19157           NCHN=NCHN+1
19158           ISIG(NCHN,1)=21
19159           ISIG(NCHN,2)=21
19160           ISIG(NCHN,3)=1
19161           SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19162  1210     CONTINUE
19163
19164         ELSEIF(ISUB.EQ.122) THEN
19165 C...q + qbar -> Q + Qbar + h0
19166           IA=KFPR(ISUBSV,2)
19167           PMF=PMAS(IA,1)
19168           FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
19169      &    (0.5D0*PMF/PMAS(24,1))**2
19170           IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH=
19171      &    FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/
19172      &    LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19173           WID2=1D0
19174           IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
19175           FACQQH=FACQQH*WID2
19176           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
19177             IKFI=1
19178             IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
19179             IF(IA.GT.10) IKFI=3
19180             FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
19181           ENDIF
19182           CALL PYQQBH(WTQQBH)
19183           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19184           HS=SHR*WDTP(0)
19185           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19186           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19187           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19188      &    FACBW=0D0
19189           DO 1220 I=MMINA,MMAXA
19190             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19191      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220
19192             NCHN=NCHN+1
19193             ISIG(NCHN,1)=I
19194             ISIG(NCHN,2)=-I
19195             ISIG(NCHN,3)=1
19196             SIGH(NCHN)=FACQQH*WTQQBH*FACBW
19197  1220     CONTINUE
19198
19199         ELSEIF(ISUB.EQ.123) THEN
19200 C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
19201 C...inner process)
19202           FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
19203           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19204      &    PARU(154+10*IHIGG)**2
19205           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19206      &    (VINT(216)-VINT(209)**2))**2
19207           FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19208           FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
19209           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19210           HS=SHR*WDTP(0)
19211           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19212           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19213           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19214      &    FACBW=0D0
19215           DO 1240 I=MMIN1,MMAX1
19216             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240
19217             IA=IABS(I)
19218             DO 1230 J=MMIN2,MMAX2
19219               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230
19220               JA=IABS(J)
19221               EI=KCHG(IA,1)*ISIGN(1,I)/3D0
19222               AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
19223               VI=AI-4D0*EI*XWV
19224               EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
19225               AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
19226               VJ=AJ-4D0*EJ*XWV
19227               FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
19228               FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
19229               NCHN=NCHN+1
19230               ISIG(NCHN,1)=I
19231               ISIG(NCHN,2)=J
19232               ISIG(NCHN,3)=1
19233               SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
19234  1230       CONTINUE
19235  1240     CONTINUE
19236
19237         ELSEIF(ISUB.EQ.124) THEN
19238 C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
19239 C...inner process)
19240           FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
19241           IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
19242      &    PARU(155+10*IHIGG)**2
19243           FACPRP=1D0/((VINT(215)-VINT(204)**2)*
19244      &    (VINT(216)-VINT(209)**2))**2
19245           FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
19246           CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
19247           HS=SHR*WDTP(0)
19248           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19249           FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
19250           IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
19251      &    FACBW=0D0
19252           DO 1260 I=MMIN1,MMAX1
19253             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260
19254             EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
19255             DO 1250 J=MMIN2,MMAX2
19256               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250
19257               EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
19258               IF(EI*EJ.GT.0D0) GOTO 1250
19259               FACLR=VINT(180+I)*VINT(180+J)
19260               NCHN=NCHN+1
19261               ISIG(NCHN,1)=I
19262               ISIG(NCHN,2)=J
19263               ISIG(NCHN,3)=1
19264               SIGH(NCHN)=FACLR*FACWW*FACBW
19265  1250       CONTINUE
19266  1260     CONTINUE
19267
19268         ELSEIF(ISUB.EQ.131) THEN
19269 C...g + g -> Z0 + q + qbar
19270
19271         ENDIF
19272
19273 C...H: 2 -> 1, tree diagrams, non-standard model processes
19274
19275       ELSEIF(ISUB.LE.160) THEN
19276         IF(ISUB.EQ.141) THEN
19277 C...f + fbar -> gamma*/Z0/Z'0
19278           SQMZP=PMAS(32,1)**2
19279           MINT(61)=2
19280           CALL PYWIDT(32,SH,WDTP,WDTE)
19281           HP0=AEM/3D0*SH
19282           HP1=AEM/3D0*XWC*SH
19283           HP2=HP1
19284           HS=SHR*VINT(117)
19285           HSP=SHR*WDTP(0)
19286           FACZP=4D0*COMFAC*3D0
19287           DO 1270 I=MMINA,MMAXA
19288             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270
19289             EI=KCHG(IABS(I),1)/3D0
19290             AI=SIGN(1D0,EI)
19291             VI=AI-4D0*EI*XWV
19292             IF(IABS(I).LT.10) THEN
19293               VPI=PARU(123-2*MOD(IABS(I),2))
19294               API=PARU(124-2*MOD(IABS(I),2))
19295             ELSE
19296               VPI=PARU(127-2*MOD(IABS(I),2))
19297               API=PARU(128-2*MOD(IABS(I),2))
19298             ENDIF
19299             HI0=HP0
19300             IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
19301             HI1=HP1
19302             IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
19303             HI2=HP2
19304             IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
19305             NCHN=NCHN+1
19306             ISIG(NCHN,1)=I
19307             ISIG(NCHN,2)=-I
19308             ISIG(NCHN,3)=1
19309             SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
19310      &      (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
19311      &      VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
19312      &      (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
19313      &      ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
19314      &      ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
19315      &      ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
19316      &      (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
19317  1270     CONTINUE
19318
19319         ELSEIF(ISUB.EQ.142) THEN
19320 C...f + fbar' -> W'+/-
19321           SQMWP=PMAS(34,1)**2
19322           CALL PYWIDT(34,SH,WDTP,WDTE)
19323           HS=SHR*WDTP(0)
19324           FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
19325           HP=AEM/(24D0*XW)*SH
19326           DO 1290 I=MMIN1,MMAX1
19327             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290
19328             IA=IABS(I)
19329             DO 1280 J=MMIN2,MMAX2
19330               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280
19331               JA=IABS(J)
19332               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280
19333               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19334      &        GOTO 1280
19335               KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19336               HI=HP*(PARU(133)**2+PARU(134)**2)
19337               IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
19338      &        VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19339               NCHN=NCHN+1
19340               ISIG(NCHN,1)=I
19341               ISIG(NCHN,2)=J
19342               ISIG(NCHN,3)=1
19343               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
19344               SIGH(NCHN)=HI*FACBW*HF
19345  1280       CONTINUE
19346  1290     CONTINUE
19347
19348         ELSEIF(ISUB.EQ.143) THEN
19349 C...f + fbar' -> H+/-
19350           SQMHC=PMAS(37,1)**2
19351           CALL PYWIDT(37,SH,WDTP,WDTE)
19352           HS=SHR*WDTP(0)
19353           FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
19354           HP=AEM/(8D0*XW)*SH/SQMW*SH
19355           DO 1310 I=MMIN1,MMAX1
19356             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310
19357             IA=IABS(I)
19358             IM=(MOD(IA,10)+1)/2
19359             DO 1300 J=MMIN2,MMAX2
19360               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300
19361               JA=IABS(J)
19362               JM=(MOD(JA,10)+1)/2
19363               IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300
19364               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19365      &        GOTO 1300
19366               IF(MOD(IA,2).EQ.0) THEN
19367                 IU=IA
19368                 IL=JA
19369               ELSE
19370                 IU=JA
19371                 IL=IA
19372               ENDIF
19373               RML=PMAS(IL,1)**2/SH
19374               RMU=PMAS(IU,1)**2/SH
19375               IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML=
19376      &        RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/
19377      &        LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-
19378      &        2D0*MSTU(118)))
19379               HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
19380               IF(IA.LE.10) HI=HI*FACA/3D0
19381               KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19382               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
19383               NCHN=NCHN+1
19384               ISIG(NCHN,1)=I
19385               ISIG(NCHN,2)=J
19386               ISIG(NCHN,3)=1
19387               SIGH(NCHN)=HI*FACBW*HF
19388  1300       CONTINUE
19389  1310     CONTINUE
19390
19391         ELSEIF(ISUB.EQ.144) THEN
19392 C...f + fbar' -> R
19393           SQMR=PMAS(40,1)**2
19394           CALL PYWIDT(40,SH,WDTP,WDTE)
19395           HS=SHR*WDTP(0)
19396           FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
19397           HP=AEM/(12D0*XW)*SH
19398           DO 1330 I=MMIN1,MMAX1
19399             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330
19400             IA=IABS(I)
19401             DO 1320 J=MMIN2,MMAX2
19402               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320
19403               JA=IABS(J)
19404               IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320
19405               HI=HP
19406               IF(IA.LE.10) HI=HI*FACA/3D0
19407               HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
19408               NCHN=NCHN+1
19409               ISIG(NCHN,1)=I
19410               ISIG(NCHN,2)=J
19411               ISIG(NCHN,3)=1
19412               SIGH(NCHN)=HI*FACBW*HF
19413  1320       CONTINUE
19414  1330     CONTINUE
19415
19416         ELSEIF(ISUB.EQ.145) THEN
19417 C...q + l -> LQ (leptoquark)
19418           SQMLQ=PMAS(39,1)**2
19419           CALL PYWIDT(39,SH,WDTP,WDTE)
19420           HS=SHR*WDTP(0)
19421           FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
19422           IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0
19423           HP=AEM/4D0*SH
19424           KFLQQ=KFDP(MDCY(39,2),1)
19425           KFLQL=KFDP(MDCY(39,2),2)
19426           DO 1350 I=MMIN1,MMAX1
19427             IF(KFAC(1,I).EQ.0) GOTO 1350
19428             IA=IABS(I)
19429             IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350
19430             DO 1340 J=MMIN2,MMAX2
19431               IF(KFAC(2,J).EQ.0) GOTO 1340
19432               JA=IABS(J)
19433               IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340
19434               IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340
19435               IF(JA.EQ.IA) GOTO 1340
19436               IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
19437               IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
19438               HI=HP*PARU(151)
19439               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
19440               NCHN=NCHN+1
19441               ISIG(NCHN,1)=I
19442               ISIG(NCHN,2)=J
19443               ISIG(NCHN,3)=1
19444               SIGH(NCHN)=HI*FACBW*HF
19445  1340       CONTINUE
19446  1350     CONTINUE
19447
19448         ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
19449 C...d + g -> d* and u + g -> u* (excited quarks)
19450           KFQSTR=KFPR(ISUB,1)
19451           KCQSTR=PYCOMP(KFQSTR)
19452           KFQEXC=MOD(KFQSTR,KEXCIT)
19453           CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
19454           HS=SHR*WDTP(0)
19455           FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
19456           FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2)
19457           IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
19458      &    FACBW=0D0
19459           HP=SH
19460           DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC
19461             DO 1360 ISDE=1,2
19462               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360
19463               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360
19464               HI=HP
19465               IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19466               IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
19467               NCHN=NCHN+1
19468               ISIG(NCHN,ISDE)=I
19469               ISIG(NCHN,3-ISDE)=21
19470               ISIG(NCHN,3)=1
19471               SIGH(NCHN)=HI*FACBW*HF
19472  1360       CONTINUE
19473  1370     CONTINUE
19474
19475         ELSEIF(ISUB.EQ.149) THEN
19476 C...g + g -> eta_techni
19477           CALL PYWIDT(38,SH,WDTP,WDTE)
19478           HS=SHR*WDTP(0)
19479           FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2)
19480           IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0
19481           HP=SH
19482           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380
19483           HI=HP*WDTP(3)
19484           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19485           NCHN=NCHN+1
19486           ISIG(NCHN,1)=21
19487           ISIG(NCHN,2)=21
19488           ISIG(NCHN,3)=1
19489           SIGH(NCHN)=HI*FACBW*HF
19490  1380     CONTINUE
19491
19492         ENDIF
19493
19494 C...I: 2 -> 2, tree diagrams, non-standard model processes
19495
19496       ELSEIF(ISUB.LE.200) THEN
19497         IF(ISUB.EQ.161) THEN
19498 C...f + g -> f' + H+/- (b + g -> t + H+/- only)
19499 C...(choice of only b and t to avoid kinematics problems)
19500           SQMHC=PMAS(37,1)**2
19501           FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
19502           DO 1400 I=MMINA,MMAXA
19503             IA=IABS(I)
19504             IF(IA.NE.5) GOTO 1400
19505             SQML=PMAS(IA,1)**2
19506             IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML*
19507      &      (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/
19508      &      LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118)))
19509             IUA=IA+MOD(IA,2)
19510             SQMQ=PMAS(IUA,1)**2
19511             FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
19512      &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+
19513      &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
19514      &      (SQMHC-SQMQ-SH)/SH)
19515             KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
19516             DO 1390 ISDE=1,2
19517               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390
19518               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390
19519               NCHN=NCHN+1
19520               ISIG(NCHN,ISDE)=I
19521               ISIG(NCHN,3-ISDE)=21
19522               ISIG(NCHN,3)=1
19523               SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
19524  1390       CONTINUE
19525  1400     CONTINUE
19526
19527         ELSEIF(ISUB.EQ.162) THEN
19528 C...q + g -> LQ + lbar; LQ=leptoquark
19529           SQMLQ=PMAS(39,1)**2
19530           FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
19531      &    (UH2+SQMLQ**2)/(UH-SQMLQ)**2
19532           KFLQQ=KFDP(MDCY(39,2),1)
19533           DO 1420 I=MMINA,MMAXA
19534             IF(IABS(I).NE.KFLQQ) GOTO 1420
19535             KCHLQ=ISIGN(1,I)
19536             DO 1410 ISDE=1,2
19537               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410
19538               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410
19539               NCHN=NCHN+1
19540               ISIG(NCHN,ISDE)=I
19541               ISIG(NCHN,3-ISDE)=21
19542               ISIG(NCHN,3)=1
19543               SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
19544  1410       CONTINUE
19545  1420     CONTINUE
19546
19547         ELSEIF(ISUB.EQ.163) THEN
19548 C...g + g -> LQ + LQbar; LQ=leptoquark
19549           SQMLQ=PMAS(39,1)**2
19550           FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)*
19551      &    (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
19552      &    (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
19553      &    ((TH-SQMLQ)*(UH-SQMLQ)))
19554           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430
19555           NCHN=NCHN+1
19556           ISIG(NCHN,1)=21
19557           ISIG(NCHN,2)=21
19558 C...Since don't know proper colour flow, randomize between alternatives
19559           ISIG(NCHN,3)=INT(1.5D0+PYR(0))
19560           SIGH(NCHN)=FACLQ
19561  1430     CONTINUE
19562
19563         ELSEIF(ISUB.EQ.164) THEN
19564 C...q + qbar -> LQ + LQbar; LQ=leptoquark
19565           SQMLQ=PMAS(39,1)**2
19566           FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)*
19567      &    (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
19568           FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)*
19569      &    (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
19570      &    ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
19571           KFLQQ=KFDP(MDCY(39,2),1)
19572           DO 1440 I=MMINA,MMAXA
19573             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
19574      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440
19575             NCHN=NCHN+1
19576             ISIG(NCHN,1)=I
19577             ISIG(NCHN,2)=-I
19578             ISIG(NCHN,3)=1
19579             SIGH(NCHN)=FACLQA
19580             IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
19581  1440     CONTINUE
19582
19583         ELSEIF(ISUB.EQ.165) THEN
19584 C...q + qbar -> l+ + l- (including contact term for compositeness)
19585           ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19586           ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19587           KFF=IABS(KFPR(ISUB,1))
19588           EF=KCHG(KFF,1)/3D0
19589           AF=SIGN(1D0,EF+0.1D0)
19590           VF=AF-4D0*EF*XWV
19591           VALF=VF+AF
19592           VARF=VF-AF
19593           FCOF=1D0
19594           IF(KFF.LE.10) FCOF=3D0
19595           WID2=1D0
19596           IF(KFF.EQ.6) WID2=WIDS(6,1)
19597           IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
19598           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19599           DO 1450 I=MMINA,MMAXA
19600             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450
19601             EI=KCHG(IABS(I),1)/3D0
19602             AI=SIGN(1D0,EI+0.1D0)
19603             VI=AI-4D0*EI*XWV
19604             VALI=VI+AI
19605             VARI=VI-AI
19606             FCOI=1D0
19607             IF(IABS(I).LE.10) FCOI=FACA/3D0
19608             IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN
19609               FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/
19610      &        (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+
19611      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19612             ELSE
19613               FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
19614      &        (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
19615             ENDIF
19616             FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
19617      &      (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
19618             FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
19619             IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND.
19620      &      MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4)
19621             NCHN=NCHN+1
19622             ISIG(NCHN,1)=I
19623             ISIG(NCHN,2)=-I
19624             ISIG(NCHN,3)=1
19625             SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
19626  1450     CONTINUE
19627
19628         ELSEIF(ISUB.EQ.166) THEN
19629 C...q + q'bar -> l + nu_l (including contact term for compositeness)
19630           WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
19631           WCIFAC=WFAC+SH2/(4D0*PARU(155)**4)
19632           KFF=IABS(KFPR(ISUB,1))
19633           FCOF=1D0
19634           IF(KFF.LE.10) FCOF=3D0
19635           DO 1470 I=MMIN1,MMAX1
19636             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470
19637             IA=IABS(I)
19638             DO 1460 J=MMIN2,MMAX2
19639               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460
19640               JA=IABS(J)
19641               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460
19642               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19643      &        GOTO 1460
19644               FCOI=1D0
19645               IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19646               WID2=1D0
19647               IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
19648      &        MOD(J,2).EQ.0)) THEN
19649                 IF(KFF.EQ.5) WID2=WIDS(6,2)
19650                 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
19651                 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
19652               ELSE
19653                 IF(KFF.EQ.5) WID2=WIDS(6,3)
19654                 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
19655                 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
19656               ENDIF
19657               NCHN=NCHN+1
19658               ISIG(NCHN,1)=I
19659               ISIG(NCHN,2)=J
19660               ISIG(NCHN,3)=1
19661               SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
19662               IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4)
19663      &        SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
19664  1460       CONTINUE
19665  1470     CONTINUE
19666
19667         ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
19668 C...d + g -> d* and u + g -> u* (excited quarks)
19669           KFQSTR=KFPR(ISUB,2)
19670           KCQSTR=PYCOMP(KFQSTR)
19671           KFQEXC=MOD(KFQSTR,KEXCIT)
19672           FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)
19673           FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)*
19674      &    (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
19675 C...Propagators: as simulated in PYOFSH and as desired
19676           GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
19677           HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
19678           CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
19679           GMMQC=SQRT(SQM4)*WDTP(0)
19680           HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
19681           FACQSA=FACQSA*HBW4C/HBW4
19682           FACQSB=FACQSB*HBW4C/HBW4
19683           DO 1490 I=MMIN1,MMAX1
19684             IA=IABS(I)
19685             IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490
19686             DO 1480 J=MMIN2,MMAX2
19687               JA=IABS(J)
19688               IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480
19689               IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
19690                 NCHN=NCHN+1
19691                 ISIG(NCHN,1)=I
19692                 ISIG(NCHN,2)=J
19693                 ISIG(NCHN,3)=1
19694                 SIGH(NCHN)=(4D0/3D0)*FACQSA
19695                 NCHN=NCHN+1
19696                 ISIG(NCHN,1)=I
19697                 ISIG(NCHN,2)=J
19698                 ISIG(NCHN,3)=2
19699                 SIGH(NCHN)=(4D0/3D0)*FACQSA
19700               ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
19701                 NCHN=NCHN+1
19702                 ISIG(NCHN,1)=I
19703                 ISIG(NCHN,2)=J
19704                 ISIG(NCHN,3)=1
19705                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19706                 SIGH(NCHN)=FACQSA
19707               ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
19708                 NCHN=NCHN+1
19709                 ISIG(NCHN,1)=I
19710                 ISIG(NCHN,2)=J
19711                 ISIG(NCHN,3)=1
19712                 SIGH(NCHN)=(8D0/3D0)*FACQSB
19713                 NCHN=NCHN+1
19714                 ISIG(NCHN,1)=I
19715                 ISIG(NCHN,2)=J
19716                 ISIG(NCHN,3)=2
19717                 SIGH(NCHN)=(8D0/3D0)*FACQSB
19718               ELSEIF(I.EQ.-J) THEN
19719                 NCHN=NCHN+1
19720                 ISIG(NCHN,1)=I
19721                 ISIG(NCHN,2)=J
19722                 ISIG(NCHN,3)=1
19723                 SIGH(NCHN)=FACQSB
19724                 NCHN=NCHN+1
19725                 ISIG(NCHN,1)=I
19726                 ISIG(NCHN,2)=J
19727                 ISIG(NCHN,3)=2
19728                 SIGH(NCHN)=FACQSB
19729               ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
19730                 NCHN=NCHN+1
19731                 ISIG(NCHN,1)=I
19732                 ISIG(NCHN,2)=J
19733                 ISIG(NCHN,3)=1
19734                 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
19735                 SIGH(NCHN)=FACQSB
19736               ENDIF
19737  1480       CONTINUE
19738  1490     CONTINUE
19739
19740         ELSEIF(ISUB.EQ.191) THEN
19741 C...q + qbar -> rho_tech0.
19742           SQMRHT=PMAS(54,1)**2
19743           CALL PYWIDT(54,SH,WDTP,WDTE)
19744           HS=SHR*WDTP(0)
19745           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19746           IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0
19747           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19748           ALPRHT=2.91D0*(3D0/PARP(144))
19749           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
19750           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19751           BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19752           BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19753           DO 1500 I=MMINA,MMAXA
19754             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
19755             IA=IABS(I)
19756             EI=KCHG(IABS(I),1)/3D0
19757             AI=SIGN(1D0,EI+0.1D0)
19758             VI=AI-4D0*EI*XWV
19759             VALI=0.5D0*(VI+AI)
19760             VARI=0.5D0*(VI-AI)
19761             HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
19762      &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
19763             IF(IA.LE.10) HI=HI*FACA/3D0
19764             NCHN=NCHN+1
19765             ISIG(NCHN,1)=I
19766             ISIG(NCHN,2)=-I
19767             ISIG(NCHN,3)=1
19768             SIGH(NCHN)=HI*FACBW*HF
19769  1500     CONTINUE
19770
19771         ELSEIF(ISUB.EQ.192) THEN
19772 C...q + qbar' -> rho_tech+/-.
19773           SQMRHT=PMAS(55,1)**2
19774           CALL PYWIDT(55,SH,WDTP,WDTE)
19775           HS=SHR*WDTP(0)
19776           FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
19777           IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0
19778           ALPRHT=2.91D0*(3D0/PARP(144))
19779           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
19780      &    (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
19781           DO 1520 I=MMIN1,MMAX1
19782             IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520
19783             IA=IABS(I)
19784             DO 1510 J=MMIN2,MMAX2
19785               IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510
19786               JA=IABS(J)
19787               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510
19788               IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
19789      &        GOTO 1510
19790               KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
19791               HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
19792               HI=HP
19793               IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
19794               NCHN=NCHN+1
19795               ISIG(NCHN,1)=I
19796               ISIG(NCHN,2)=J
19797               ISIG(NCHN,3)=1
19798               SIGH(NCHN)=HI*FACBW*HF
19799  1510       CONTINUE
19800  1520     CONTINUE
19801
19802         ELSEIF(ISUB.EQ.193) THEN
19803 C...q + qbar -> omega_tech0.
19804           SQMOMT=PMAS(56,1)**2
19805           CALL PYWIDT(56,SH,WDTP,WDTE)
19806           HS=SHR*WDTP(0)
19807           FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
19808           IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0
19809           HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
19810           ALPRHT=2.91D0*(3D0/PARP(144))
19811           HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
19812      &    (2D0*PARP(143)-1D0)**2
19813           BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19814           BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19815           DO 1530 I=MMINA,MMAXA
19816             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530
19817             IA=IABS(I)
19818             EI=KCHG(IABS(I),1)/3D0
19819             AI=SIGN(1D0,EI+0.1D0)
19820             VI=AI-4D0*EI*XWV
19821             VALI=0.5D0*(VI+AI)
19822             VARI=0.5D0*(VI-AI)
19823             HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
19824      &      (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
19825             IF(IA.LE.10) HI=HI*FACA/3D0
19826             NCHN=NCHN+1
19827             ISIG(NCHN,1)=I
19828             ISIG(NCHN,2)=-I
19829             ISIG(NCHN,3)=1
19830             SIGH(NCHN)=HI*FACBW*HF
19831  1530     CONTINUE
19832
19833         ELSEIF(ISUB.EQ.194) THEN
19834 C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
19835           SQMRHT=PMAS(54,1)**2
19836           CALL PYWIDT(54,SH,WDTP,WDTE)
19837           HSRHT=SHR*WDTP(0)
19838           BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2)
19839           BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2)
19840           XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19841           SQMOMT=PMAS(56,1)**2
19842           CALL PYWIDT(56,SH,WDTP,WDTE)
19843           HSOMT=SHR*WDTP(0)
19844           BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2)
19845           BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2)
19846           XWOMT=0.5D0/(1D0-XW)
19847           KFF=IABS(KFPR(ISUB,1))
19848           EF=KCHG(KFF,1)/3D0
19849           AF=SIGN(1D0,EF+0.1D0)
19850           VF=AF-4D0*EF*XWV
19851           VALF=0.5D0*(VF+AF)
19852           VARF=0.5D0*(VF-AF)
19853           FCOF=1D0
19854           IF(KFF.LE.10) FCOF=3D0
19855           WID2=1D0
19856           IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
19857           IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
19858           ALPRHT=2.91D0*(3D0/PARP(144))
19859           FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2
19860           BWZ=SH/(SH-SQMZ)
19861           ALEFTF=EF+VALF*XWRHT*BWZ
19862           ARIGHF=EF+VARF*XWRHT*BWZ
19863           BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19864           BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19865           DO 1540 I=MMINA,MMAXA
19866             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540
19867             EI=KCHG(IABS(I),1)/3D0
19868             AI=SIGN(1D0,EI+0.1D0)
19869             VI=AI-4D0*EI*XWV
19870             VALI=0.5D0*(VI+AI)
19871             VARI=0.5D0*(VI-AI)
19872             FCOI=1D0
19873             IF(IABS(I).LE.10) FCOI=FACA/3D0
19874             ALEFTI=EI+VALI*XWRHT*BWZ
19875             ARIGHI=EI+VARI*XWRHT*BWZ
19876             BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19877             BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0)
19878             DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+
19879      &      (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2
19880             DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+
19881      &      (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2
19882             DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+
19883      &      (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2
19884             DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+
19885      &      (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2
19886             FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2
19887             NCHN=NCHN+1
19888             ISIG(NCHN,1)=I
19889             ISIG(NCHN,2)=-I
19890             ISIG(NCHN,3)=1
19891             SIGH(NCHN)=FACTC*FCOI*FACSIG
19892  1540     CONTINUE
19893
19894         ENDIF
19895
19896 CMRENNA++
19897 C...J: 2 -> 2, tree diagrams, SUSY processes
19898
19899       ELSEIF(ISUB.LE.210) THEN
19900         IF(ISUB.EQ.201) THEN
19901 C...f + fbar -> e_L + e_Lbar
19902           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
19903           DO 1570 I=MMIN1,MMAX1
19904             IA=IABS(I)
19905             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570
19906             EI=KCHG(IA,1)/3D0
19907             TT3I=SIGN(1D0,EI+1D-6)/2D0
19908             EJ=-1D0
19909             TT3J=-1D0/2D0
19910             FCOL=1D0
19911 C...Color factor for e+ e-
19912             IF(IA.GE.11) FCOL=3D0
19913             IF(ILR.EQ.1) THEN
19914               A1=SFMIX(KFID,3)**2
19915               A2=SFMIX(KFID,4)**2
19916             ELSEIF(ILR.EQ.0) THEN
19917               A1=SFMIX(KFID,1)**2
19918               A2=SFMIX(KFID,2)**2
19919             ENDIF
19920             XLQ=(TT3J-EJ*XW)*A1
19921             XRQ=(-EJ*XW)*A2
19922             XLF=(TT3I-EI*XW)
19923             XRF=(-EI*XW)
19924             TAA=2D0*(EI*EJ)**2
19925             TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
19926             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
19927             TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
19928             TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
19929             TNN=0.0D0
19930             TAN=0.0D0
19931             TZN=0.0D0
19932             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19933               FAC2=SQRT(2D0)
19934               TNN1=0D0
19935               TNN2=0D0
19936               TNN3=0D0
19937               DO 1560 II=1,4
19938                 DK=1D0/(TH-SMZ(II)**2)
19939                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
19940      &          ZMIX(II,1))
19941                 FREK=FAC2*TANW*EI*ZMIX(II,1)
19942                 TNN1=TNN1+FLEK**2*DK
19943                 TNN2=TNN2+FREK**2*DK
19944                 DO 1550 JJ=1,4
19945                   DL=1D0/(TH-SMZ(JJ)**2)
19946                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
19947      &            ZMIX(JJ,1))
19948                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
19949                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
19950  1550           CONTINUE
19951  1560         CONTINUE
19952               TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
19953               TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
19954               TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
19955      &        (TNN1*XLF*A1+TNN2*XRF*A2)
19956               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
19957      &        (1D0-SQMZ/SH)/SH
19958               TZN=TZN/XW**2/XW1
19959               TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
19960             ENDIF
19961             FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
19962             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
19963             FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
19964             NCHN=NCHN+1
19965             ISIG(NCHN,1)=I
19966             ISIG(NCHN,2)=-I
19967             ISIG(NCHN,3)=1
19968             SIGH(NCHN)=FACQQ1+FACQQ2
19969  1570     CONTINUE
19970
19971         ELSEIF(ISUB.EQ.203) THEN
19972 C...f + fbar -> e_L + e_Rbar
19973           DO 1600 I=MMIN1,MMAX1
19974             IA=IABS(I)
19975             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
19976             EI=KCHG(IABS(I),1)/3D0
19977             TT3I=SIGN(1D0,EI)/2D0
19978             EJ=-1
19979             TT3J=-1D0/2D0
19980             FCOL=1D0
19981 C...Color factor for e+ e-
19982             IF(IA.GE.11) FCOL=3D0
19983             A1=SFMIX(KFID,1)**2
19984             A2=SFMIX(KFID,2)**2
19985             XLQ=(TT3J-EJ*XW)
19986             XRQ=(-EJ*XW)
19987             XLF=(TT3I-EI*XW)
19988             XRF=(-EI*XW)
19989             TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
19990             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
19991             TNN=0.0D0
19992             TZN=0.0D0
19993             IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
19994               FAC2=SQRT(2D0)
19995               TNN1=0D0
19996               TNN2=0D0
19997               TNN3=0D0
19998               DO 1590 II=1,4
19999                 DK=1D0/(TH-SMZ(II)**2)
20000                 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
20001      &          ZMIX(II,1))
20002                 FREK=FAC2*TANW*EI*ZMIX(II,1)
20003                 TNN1=TNN1+FLEK**2*DK
20004                 TNN2=TNN2+FREK**2*DK
20005                 DO 1580 JJ=1,4
20006                   DL=1D0/(TH-SMZ(JJ)**2)
20007                   FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
20008      &            ZMIX(JJ,1))
20009                   FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
20010                   TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
20011  1580           CONTINUE
20012  1590         CONTINUE
20013               TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
20014               TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
20015               TZN=(UH*TH-SQM3*SQM4)*A1*A2
20016               TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
20017               TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
20018      &        (1D0-SQMZ/SH)/SH
20019             ENDIF
20020             FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
20021             FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
20022             FACQQ=(FACQQ1+FACQQ2)
20023             NCHN=NCHN+1
20024             ISIG(NCHN,1)=I
20025             ISIG(NCHN,2)=-I
20026             ISIG(NCHN,3)=1
20027             SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20028      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20029             NCHN=NCHN+1
20030             ISIG(NCHN,1)=I
20031             ISIG(NCHN,2)=-I
20032             ISIG(NCHN,3)=2
20033             SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20034      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20035  1600     CONTINUE
20036
20037         ELSEIF(ISUB.EQ.210) THEN
20038 C...q + qbar' -> W*- > ~l_L + ~nu_L
20039           FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
20040           FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
20041           DO 1620 I=MMIN1,MMAX1
20042             IA=IABS(I)
20043             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620
20044             DO 1610 J=MMIN2,MMAX2
20045               JA=IABS(J)
20046               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610
20047               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610
20048               FCKM=3D0
20049               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20050               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20051               KCHW=2
20052               IF(KCHSUM.LT.0) KCHW=3
20053               NCHN=NCHN+1
20054               ISIG(NCHN,1)=I
20055               ISIG(NCHN,2)=J
20056               ISIG(NCHN,3)=1
20057               SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),
20058      &        5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20059  1610       CONTINUE
20060  1620     CONTINUE
20061         ENDIF
20062
20063       ELSEIF(ISUB.LE.220) THEN
20064         IF(ISUB.EQ.213) THEN
20065 C...f + fbar -> ~nu_L + ~nu_Lbar
20066           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20067           PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
20068           XLL=0.5D0
20069           XLR=0.0D0
20070           DO 1630 I=MMIN1,MMAX1
20071             IA=IABS(I)
20072             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
20073             EI=KCHG(IA,1)/3D0
20074             FCOL=1D0
20075 C...Color factor for e+ e-
20076             IF(IA.GE.11) FCOL=3D0
20077             XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20078             XRQ=-EI*XW
20079             TZC=0.0D0
20080             TCC=0.0D0
20081             IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
20082               TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
20083      &        (TH-SMW(2)**2)
20084               TCC=TZC**2
20085               TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
20086             ENDIF
20087             FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
20088             FACQQ2=TZC+TCC/4D0
20089             NCHN=NCHN+1
20090             ISIG(NCHN,1)=I
20091             ISIG(NCHN,2)=-I
20092             ISIG(NCHN,3)=1
20093             SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
20094      &      *AEM**2*FCOL/3D0/XW**2
20095  1630     CONTINUE
20096
20097         ELSEIF(ISUB.EQ.216) THEN
20098 C...q + qbar -> ~chi0_1 + ~chi0_1
20099           IF(IZID1.EQ.IZID2) THEN
20100             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20101           ELSE
20102             COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20103      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20104           ENDIF
20105           FACGG1=COMFAC*AEM**2/3D0/XW**2
20106           IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0
20107           ZM12=SQM3
20108           ZM22=SQM4
20109           SR2=SQRT(2D0)
20110           WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20111           WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20112           XS2 = SMZ(IZID1)*SMZ(IZID2)/SH
20113           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20114           REPRPZ = (SH-SQMZ)/PROPZ2
20115           OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+
20116      &    ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0
20117           DO 1640 I=MMINA,MMAXA
20118             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640
20119             EI=KCHG(IABS(I),1)/3D0
20120             FCOL=1D0
20121             IF(ABS(I).GE.11) FCOL=3D0
20122             XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20123             XRQ=-EI*XW
20124             XLQ=XLQ/XW1
20125             XRQ=XRQ/XW1
20126 C...Factored out sqrt(2)
20127             FR1=TANW*EI*ZMIX(IZID1,1)
20128             FR2=TANW*EI*ZMIX(IZID2,1)
20129             FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW*
20130      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0
20131             FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW*
20132      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0
20133             FR12=FR1**2
20134             FR22=FR2**2
20135             FL12=FL1**2
20136             FL22=FL2**2
20137             XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
20138             XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
20139             FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2)
20140             FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2-
20141      &      2D0*XS2*SH2/(TH-XML2)/(UH-XML2))
20142             FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2-
20143      &      2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2))
20144             FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/
20145      &      (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) )
20146             FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/
20147      &      (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) )
20148             NCHN=NCHN+1
20149             ISIG(NCHN,1)=I
20150             ISIG(NCHN,2)=-I
20151             ISIG(NCHN,3)=1
20152             SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU)
20153  1640     CONTINUE
20154         ENDIF
20155
20156       ELSEIF(ISUB.LE.230) THEN
20157         IF(ISUB.EQ.226) THEN
20158 C...f + fbar -> ~chi+_1 + ~chi-_1
20159           FACGG1=COMFAC*AEM**2/3D0/XW**2
20160           ZM12=SQM3
20161           ZM22=SQM4
20162           WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20163           WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20164           WS2 = SMW(IZID1)*SMW(IZID2)/SH
20165           PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
20166           REPRPZ = (SH-SQMZ)/PROPZ2
20167           DIFF=0D0
20168           IF(IZID1.EQ.IZID2) DIFF=1D0
20169           DO 1650 I=MMINA,MMAXA
20170             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650
20171             EI=KCHG(IABS(I),1)/3D0
20172             FCOL=1D0
20173             IF(IABS(I).GE.11) FCOL=3D0
20174             XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
20175             XRQ=-EI*XW
20176             XLQ=XLQ/XW1
20177             XRQ=XRQ/XW1
20178             XLQ2=XLQ**2
20179             XRQ2=XRQ**2
20180             OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)-
20181      &      VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF
20182             ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)-
20183      &      UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF
20184             ORP2=ORP**2
20185             OLP2=OLP**2
20186 C...u-type quark - d-type squark
20187             IF(MOD(I,2).EQ.0) THEN
20188               FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1)
20189               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
20190 C...d-type quark - u-type squark
20191             ELSE
20192               FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1)
20193               XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
20194             ENDIF
20195             FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2
20196             FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+
20197      &      4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)*
20198      &      (WU2-WT2))*SH2/PROPZ2
20199             FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2
20200             FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+
20201      &      WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI)
20202             FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI)
20203             FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2
20204             FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL
20205             NCHN=NCHN+1
20206             ISIG(NCHN,1)=I
20207             ISIG(NCHN,2)=-I
20208             ISIG(NCHN,3)=1
20209             IF(IZID1.EQ.IZID2) THEN
20210               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20211             ELSE
20212               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20213      &        WIDS(PYCOMP(KFPR(ISUBSV,1)),2)
20214               NCHN=NCHN+1
20215               ISIG(NCHN,1)=I
20216               ISIG(NCHN,2)=-I
20217               ISIG(NCHN,3)=2
20218               SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20219      &        WIDS(PYCOMP(KFPR(ISUBSV,1)),3)
20220             ENDIF
20221  1650     CONTINUE
20222
20223         ELSEIF(ISUB.EQ.229) THEN
20224 C...q + qbar' -> ~chi0_1 + ~chi+-_1
20225           FACGG1=COMFAC*AEM**2/6D0/XW**2
20226           ZM12=SQM3
20227           ZM22=SQM4
20228           ZMU2  = PMAS(PYCOMP(KSUSY1+2),1)**2
20229           ZMD2  = PMAS(PYCOMP(KSUSY1+1),1)**2
20230           WU2 = (UH-ZM12)*(UH-ZM22)/SH2
20231           WT2 = (TH-ZM12)*(TH-ZM22)/SH2
20232           WS2 = SMW(IZID1)*SMZ(IZID2)/SH
20233           RT2I = 1D0/SQRT(2D0)
20234           PROPW = ((SH-SQMW)**2+WWID**2*SQMW)
20235           OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+
20236      &    ZMIX(IZID2,2)*VMIX(IZID1,1)
20237           OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+
20238      &    ZMIX(IZID2,2)*UMIX(IZID1,1)
20239           OL2=OL**2
20240           OR2=OR**2
20241           CROSS=2D0*OL*OR
20242           FACST0=UMIX(IZID1,1)
20243           FACSU0=VMIX(IZID1,1)
20244           FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20245           FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0)
20246           FACT0=FACST0**2
20247           FACU0=FACSU0**2
20248           FACTU0=FACSU0*FACST0
20249           FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR
20250      &    + SH2*WS2*OL)*FACST0
20251           FACSU =  2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL
20252      &    + SH2*WS2*OR)*FACSU0
20253           FACT = WT2*SH2/(TH-ZMD2)**2*FACT0
20254           FACU = WU2*SH2/(UH-ZMU2)**2*FACU0
20255           FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0
20256           FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2
20257           FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST)
20258           DO 1670 I=MMIN1,MMAX1
20259             IA=IABS(I)
20260             IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670
20261             DO 1660 J=MMIN2,MMAX2
20262               JA=IABS(J)
20263               IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660
20264               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660
20265               FCKM=3D0
20266               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20267               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20268               KCHW=2
20269               IF(KCHSUM.LT.0) KCHW=3
20270               NCHN=NCHN+1
20271               ISIG(NCHN,1)=I
20272               ISIG(NCHN,2)=J
20273               ISIG(NCHN,3)=1
20274               SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20275      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20276  1660       CONTINUE
20277  1670     CONTINUE
20278         ENDIF
20279
20280       ELSEIF(ISUB.LE.240) THEN
20281         IF(ISUB.EQ.237) THEN
20282 C...q + qbar -> gluino + ~chi0_1
20283           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20284      &    WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20285           FAC0=COMFAC*AS*AEM*4D0/9D0/XW
20286           GM2=SQM3
20287           ZM2=SQM4
20288           DO 1680 I=MMINA,MMAXA
20289             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680
20290             EI=KCHG(IABS(I),1)/3D0
20291             IA=IABS(I)
20292             XLQC = -TANW*EI*ZMIX(IZID,1)
20293             XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20294      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20295             XLQ2=XLQC**2
20296             XRQ2=XRQC**2
20297             XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
20298             XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
20299             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
20300             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
20301             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
20302             SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20303             ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
20304             AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
20305             ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
20306             SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
20307             NCHN=NCHN+1
20308             ISIG(NCHN,1)=I
20309             ISIG(NCHN,2)=-I
20310             ISIG(NCHN,3)=1
20311             SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
20312  1680     CONTINUE
20313         ENDIF
20314
20315       ELSEIF(ISUB.LE.250) THEN
20316         IF(ISUB.EQ.241) THEN
20317 C...q + qbar' -> ~chi+-_1 + gluino
20318           FACWG=COMFAC*AS*AEM/XW*2D0/9D0
20319           GM2=SQM3
20320           ZM2=SQM4
20321           FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
20322           FAC0=UMIX(IZID,1)**2
20323           FAC1=VMIX(IZID,1)**2
20324           DO 1700 I=MMIN1,MMAX1
20325             IA=IABS(I)
20326             IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700
20327             DO 1690 J=MMIN2,MMAX2
20328               JA=IABS(J)
20329               IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690
20330               IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690
20331               FCKM=1D0
20332               IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
20333               KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
20334               KCHW=2
20335               IF(KCHSUM.LT.0) KCHW=3
20336               XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
20337               XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
20338               ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
20339               AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
20340               ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
20341               XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
20342               XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
20343               ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
20344               AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
20345               ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
20346      &        SH/(TH-XMU2)/(UH-XMD2))/2D0
20347               NCHN=NCHN+1
20348               ISIG(NCHN,1)=I
20349               ISIG(NCHN,2)=J
20350               ISIG(NCHN,3)=1
20351               SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
20352      &        FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20353      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
20354  1690       CONTINUE
20355  1700     CONTINUE
20356
20357         ELSEIF(ISUB.EQ.243) THEN
20358 C...q + qbar -> gluino + gluino
20359           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20360           XMT=SQM3-TH
20361           XMU=SQM3-UH
20362           DO 1710 I=MMINA,MMAXA
20363             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
20364      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
20365             NCHN=NCHN+1
20366             XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
20367             XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
20368             FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20369      &      2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20370      &      XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20371      &      SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20372             XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
20373             XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
20374             FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
20375      &      2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+
20376      &      XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST +
20377      &      SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU )
20378             ISIG(NCHN,1)=I
20379             ISIG(NCHN,2)=-I
20380             ISIG(NCHN,3)=1
20381 C...1/2 for identical particles
20382             SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
20383  1710     CONTINUE
20384
20385         ELSEIF(ISUB.EQ.244) THEN
20386 C...g + g -> gluino + gluino
20387           COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20388           XMT=SQM3-TH
20389           XMU=SQM3-UH
20390           FACQQ1=COMFAC*AS**2*9D0/4D0*(
20391      &    (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
20392      &    (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
20393           FACQQ2=COMFAC*AS**2*9D0/4D0*(
20394      &    (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
20395      &    (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
20396           FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
20397      &    SQM3*(SH-4D0*SQM3)/XMT/XMU)
20398           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720
20399           NCHN=NCHN+1
20400           ISIG(NCHN,1)=21
20401           ISIG(NCHN,2)=21
20402           ISIG(NCHN,3)=1
20403           SIGH(NCHN)=FACQQ1/2D0
20404           NCHN=NCHN+1
20405           ISIG(NCHN,1)=21
20406           ISIG(NCHN,2)=21
20407           ISIG(NCHN,3)=2
20408           SIGH(NCHN)=FACQQ2/2D0
20409           NCHN=NCHN+1
20410           ISIG(NCHN,1)=21
20411           ISIG(NCHN,2)=21
20412           ISIG(NCHN,3)=3
20413           SIGH(NCHN)=FACQQ3/2D0
20414  1720     CONTINUE
20415
20416         ELSEIF(ISUB.EQ.246) THEN
20417 C...g + q_j -> ~chi0_1 + ~q_j
20418           FAC0=COMFAC*AS*AEM/6D0/XW
20419           ZM2=SQM4
20420           QM2=SQM3
20421           FACZQ0=FAC0*( (ZM2-TH)/SH +
20422      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20423      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20424           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20425           DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ
20426             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740
20427             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
20428             EI=KCHG(IABS(I),1)/3D0
20429             IA=IABS(I)
20430             XRQZ = -TANW*EI*ZMIX(IZID,1)
20431             XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
20432      &      (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
20433             IF(ILR.EQ.0) THEN
20434               BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
20435             ELSE
20436               BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
20437             ENDIF
20438             FACZQ=FACZQ0*BS
20439             KCHQ=2
20440             IF(I.LT.0) KCHQ=3
20441             DO 1730 ISDE=1,2
20442               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730
20443               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730
20444               NCHN=NCHN+1
20445               ISIG(NCHN,ISDE)=I
20446               ISIG(NCHN,3-ISDE)=21
20447               ISIG(NCHN,3)=1
20448               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20449      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20450  1730       CONTINUE
20451  1740     CONTINUE
20452         ENDIF
20453
20454       ELSEIF(ISUB.LE.260) THEN
20455         IF(ISUB.EQ.254) THEN
20456 C...g + q_j -> ~chi1_1 + ~q_i
20457           FAC0=COMFAC*AS*AEM/12D0/XW
20458           ZM2=SQM4
20459           QM2=SQM3
20460           AU=UMIX(IZID,1)**2
20461           AD=VMIX(IZID,1)**2
20462           FACZQ0=FAC0*( (ZM2-TH)/SH +
20463      &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
20464      &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
20465           KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
20466           IF(MOD(KFNSQ1,2).EQ.0) THEN
20467             KFNSQ=KFNSQ1-1
20468             KCHW=2
20469           ELSE
20470             KFNSQ=KFNSQ1+1
20471             KCHW=3
20472           ENDIF
20473           DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ
20474             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760
20475             IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760
20476             IA=IABS(I)
20477             IF(MOD(IA,2).EQ.0) THEN
20478               FACZQ=FACZQ0*AU
20479             ELSE
20480               FACZQ=FACZQ0*AD
20481             ENDIF
20482             FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
20483             KCHQ=2
20484             IF(I.LT.0) KCHQ=3
20485             KCHWQ=KCHW
20486             IF(I.LT.0) KCHWQ=5-KCHW
20487             DO 1750 ISDE=1,2
20488               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750
20489               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750
20490               NCHN=NCHN+1
20491               ISIG(NCHN,ISDE)=I
20492               ISIG(NCHN,3-ISDE)=21
20493               ISIG(NCHN,3)=1
20494               SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20495      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
20496  1750       CONTINUE
20497  1760     CONTINUE
20498
20499         ELSEIF(ISUB.EQ.258) THEN
20500 C...g + q_j -> gluino + ~q_i
20501           XG2=SQM4
20502           XQ2=SQM3
20503           XMT=XG2-TH
20504           XMU=XG2-UH
20505           XST=XQ2-TH
20506           XSU=XQ2-UH
20507           FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
20508      &    ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
20509      &    0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
20510      &    (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
20511           FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
20512      &    (SH*(UH+XG2)
20513      &    +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
20514      &    0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
20515      &    (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
20516           FACQG1=COMFAC*AS**2*FACQG1/2D0
20517           FACQG2=COMFAC*AS**2*FACQG2/2D0
20518           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20519           DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ
20520             IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780
20521             IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780
20522             KCHQ=2
20523             IF(I.LT.0) KCHQ=3
20524             FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20525      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20526             DO 1770 ISDE=1,2
20527               IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770
20528               IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770
20529               NCHN=NCHN+1
20530               ISIG(NCHN,ISDE)=I
20531               ISIG(NCHN,3-ISDE)=21
20532               ISIG(NCHN,3)=1
20533               SIGH(NCHN)=FACQG1*FACSEL
20534               NCHN=NCHN+1
20535               ISIG(NCHN,ISDE)=I
20536               ISIG(NCHN,3-ISDE)=21
20537               ISIG(NCHN,3)=2
20538               SIGH(NCHN)=FACQG2*FACSEL
20539  1770       CONTINUE
20540  1780     CONTINUE
20541         ENDIF
20542
20543       ELSEIF(ISUB.LE.270) THEN
20544         IF(ISUB.EQ.261) THEN
20545 C...q_i + q_ibar -> ~t_1 + ~t_1bar
20546           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
20547      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20548           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20549           FAC0=AS**2*4D0/9D0
20550           DO 1790 I=MMIN1,MMAX1
20551             IA=IABS(I)
20552             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790
20553             IF(IA.GE.11.AND.IA.LE.18) THEN
20554               EI=KCHG(IA,1)/3D0
20555               EJ=KCHG(KFNSQ,1)/3D0
20556               T3I=SIGN(1D0,EI)/2D0
20557               T3J=SIGN(1D0,EJ)/2D0
20558               XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
20559               XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
20560               XLF=2D0*(T3I-EI*XW)
20561               XRF=2D0*(-EI*XW)
20562               TAA=0.5D0*(EI*EJ)**2
20563               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20564               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20565               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20566               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20567               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20568             ENDIF
20569             NCHN=NCHN+1
20570             ISIG(NCHN,1)=I
20571             ISIG(NCHN,2)=-I
20572             ISIG(NCHN,3)=1
20573             SIGH(NCHN)=FACQQ1*FAC0
20574  1790     CONTINUE
20575
20576         ELSEIF(ISUB.EQ.263) THEN
20577 C...f + fbar -> ~t1 + ~t2bar
20578           DO 1800 I=MMIN1,MMAX1
20579             IA=IABS(I)
20580             IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800
20581             EI=KCHG(IABS(I),1)/3D0
20582             TT3I=SIGN(1D0,EI)/2D0
20583             EJ=2D0/3D0
20584             TT3J=1D0/2D0
20585             FCOL=1D0
20586 C...Color factor for e+ e-
20587             IF(IA.GE.11) FCOL=3D0
20588             XLQ=2D0*(TT3J-EJ*XW)
20589             XRQ=2D0*(-EJ*XW)
20590             XLF=2D0*(TT3I-EI*XW)
20591             XRF=2D0*(-EI*XW)
20592             TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
20593             TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
20594             TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20595 C...Factor of 2 for t1 t2bar + t2 t1bar
20596             FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
20597             FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
20598             NCHN=NCHN+1
20599             ISIG(NCHN,1)=I
20600             ISIG(NCHN,2)=-I
20601             ISIG(NCHN,3)=1
20602             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
20603      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
20604             NCHN=NCHN+1
20605             ISIG(NCHN,1)=I
20606             ISIG(NCHN,2)=-I
20607             ISIG(NCHN,3)=2
20608             SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
20609      &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
20610  1800     CONTINUE
20611
20612         ELSEIF(ISUB.EQ.264) THEN
20613 C...g + g -> ~t_1 + ~t_1bar
20614           XSU=SQM3-UH
20615           XST=SQM3-TH
20616           FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
20617      &    WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20618           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20619           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20620           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810
20621           NCHN=NCHN+1
20622           ISIG(NCHN,1)=21
20623           ISIG(NCHN,2)=21
20624           ISIG(NCHN,3)=1
20625           SIGH(NCHN)=FACQQ1
20626           NCHN=NCHN+1
20627           ISIG(NCHN,1)=21
20628           ISIG(NCHN,2)=21
20629           ISIG(NCHN,3)=2
20630           SIGH(NCHN)=FACQQ2
20631  1810     CONTINUE
20632         ENDIF
20633
20634       ELSEIF(ISUB.LE.280) THEN
20635         IF(ISUB.EQ.271) THEN
20636 C...q + q' -> ~q + ~q' (~g exchange)
20637           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20638           XMT=XMG2-TH
20639           XMU=XMG2-UH
20640           XSU1=SQM3-UH
20641           XSU2=SQM4-UH
20642           XST1=SQM3-TH
20643           XST2=SQM4-TH
20644           IF(ILR.EQ.1) THEN
20645             FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
20646             FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
20647             FACQQB=0.0D0
20648           ELSE
20649             FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 )
20650             FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 )
20651             FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
20652      &      XMT/XMU )
20653           ENDIF
20654           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20655           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20656           DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI
20657             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830
20658             IA=IABS(I)
20659             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830
20660             KCHQ=2
20661             IF(I.LT.0) KCHQ=3
20662             DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20663               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820
20664               JA=IABS(J)
20665               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820
20666               IF(I*J.LT.0) GOTO 1820
20667               NCHN=NCHN+1
20668               ISIG(NCHN,1)=I
20669               ISIG(NCHN,2)=J
20670               ISIG(NCHN,3)=1
20671               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20672      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20673               IF(I.EQ.J) THEN
20674                 IF(ISUBSV.LE.272) THEN
20675                   SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20676      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20677                 ELSE
20678                   SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF*
20679      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20680      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20681                 ENDIF
20682                 NCHN=NCHN+1
20683                 ISIG(NCHN,1)=I
20684                 ISIG(NCHN,2)=J
20685                 ISIG(NCHN,3)=2
20686                 IF(ISUBSV.LE.272) THEN
20687                   SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20688      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
20689                 ELSE
20690                   SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF*
20691      &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20692      &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
20693                 ENDIF
20694               ENDIF
20695  1820       CONTINUE
20696  1830     CONTINUE
20697
20698         ELSEIF(ISUB.EQ.274) THEN
20699 C...q + qbar -> ~q' + ~qbar'
20700           XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
20701           XMT=XMG2-TH
20702           XMU=XMG2-UH
20703           IF(ILR.EQ.0) THEN
20704             FACQQ1=COMFAC*AS**2*4D0/9D0*(
20705      &      (UH*TH-SQM3*SQM4)/XMT**2 )
20706             FACQQB=COMFAC*AS**2*4D0/9D0*(
20707      &      (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2))
20708             FACQQB=FACQQB+FACQQ1
20709           ELSE
20710             FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )
20711             FACQQB=FACQQ1
20712           ENDIF
20713           KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
20714           KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
20715           DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI
20716             IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850
20717             IA=IABS(I)
20718             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850
20719             KCHQ=2
20720             IF(I.LT.0) KCHQ=3
20721             DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
20722               IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840
20723               JA=IABS(J)
20724               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840
20725               IF(I*J.GT.0) GOTO 1840
20726               NCHN=NCHN+1
20727               ISIG(NCHN,1)=I
20728               ISIG(NCHN,2)=J
20729               ISIG(NCHN,3)=1
20730               SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
20731      &        WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
20732               IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
20733      &        WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20734  1840       CONTINUE
20735  1850     CONTINUE
20736
20737         ELSEIF(ISUB.EQ.277) THEN
20738 C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
20739 C...if i .eq. j covered in 274
20740           FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
20741           KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
20742           FAC0=0D0
20743           DO 1860 I=MMIN1,MMAX1
20744             IA=IABS(I)
20745             IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.
20746      &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
20747             IF(IA.EQ.KFNSQ) GOTO 1860
20748             IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
20749               EI=KCHG(IA,1)/3D0
20750               EJ=KCHG(KFNSQ,1)/3D0
20751               T3J=SIGN(0.5D0,EJ)
20752               T3I=SIGN(1D0,EI)/2D0
20753               IF(ILR.EQ.0) THEN
20754                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
20755                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
20756               ELSE
20757                 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
20758                 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
20759               ENDIF
20760               XLF=2D0*(T3I-EI*XW)
20761               XRF=2D0*(-EI*XW)
20762               IF(ILR.EQ.0) THEN
20763                 XRQ=0D0
20764               ELSE
20765                 XLQ=0D0
20766               ENDIF
20767               TAA=0.5D0*(EI*EJ)**2
20768               TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
20769               TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
20770               TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
20771               TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
20772               FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
20773             ELSEIF(IA.LE.6) THEN
20774               FAC0=AS**2*8D0/9D0/2D0
20775             ENDIF
20776             NCHN=NCHN+1
20777             ISIG(NCHN,1)=I
20778             ISIG(NCHN,2)=-I
20779             ISIG(NCHN,3)=1
20780             SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20781  1860     CONTINUE
20782
20783         ELSEIF(ISUB.EQ.279) THEN
20784 C...g + g -> ~q_j + ~q_jbar
20785           XSU=SQM3-UH
20786           XST=SQM3-TH
20787 C...5=RKF because ~t ~tbar treated separately
20788           FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
20789           FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
20790           FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
20791           IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870
20792           NCHN=NCHN+1
20793           ISIG(NCHN,1)=21
20794           ISIG(NCHN,2)=21
20795           ISIG(NCHN,3)=1
20796           SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20797           NCHN=NCHN+1
20798           ISIG(NCHN,1)=21
20799           ISIG(NCHN,2)=21
20800           ISIG(NCHN,3)=2
20801           SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
20802  1870     CONTINUE
20803
20804         ENDIF
20805 CMRENNA--
20806       ENDIF
20807
20808 C...Multiply with parton distributions
20809       IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
20810         DO 1880 ICHN=1,NCHN
20811           IF(MINT(45).GE.2) THEN
20812             KFL1=ISIG(ICHN,1)
20813             SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
20814           ENDIF
20815           IF(MINT(46).GE.2) THEN
20816             KFL2=ISIG(ICHN,2)
20817             SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
20818           ENDIF
20819           SIGS=SIGS+SIGH(ICHN)
20820  1880   CONTINUE
20821       ENDIF
20822
20823       RETURN
20824       END
20825
20826 C*********************************************************************
20827
20828 *$ CREATE PYPDFU.FOR
20829 *COPY PYPDFU
20830 C...PYPDFU
20831 C...Gives electron, photon, pi+, neutron, proton and hyperon
20832 C...parton distributions according to a few different parametrizations.
20833 C...Note that what is coded is x times the probability distribution,
20834 C...i.e. xq(x,Q2) etc.
20835
20836       SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
20837
20838 C...Double precision and integer declarations.
20839       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20840       INTEGER PYK,PYCHGE,PYCOMP
20841 C...Commonblocks.
20842       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20843       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20844       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20845       COMMON/PYINT1/MINT(400),VINT(400)
20846       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
20847      &XPDIR(-6:6)
20848       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/
20849 C...Local arrays.
20850       DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
20851      &XPPI(-6:6),XPPR(-6:6)
20852
20853 C...Interface to PDFLIB.
20854       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
20855       SAVE /W50513/
20856       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
20857      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
20858       CHARACTER*20 PARM(20)
20859       DATA VALUE/20*0D0/,PARM/20*' '/
20860
20861 C...Data related to Schuler-Sjostrand photon distributions.
20862       DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
20863
20864 C...Reset parton distributions.
20865       MINT(92)=0
20866       DO 100 KFL=-25,25
20867         XPQ(KFL)=0D0
20868   100 CONTINUE
20869
20870 C...Check x and particle species.
20871       IF(X.LE.0D0.OR.X.GE.1D0) THEN
20872         WRITE(MSTU(11),5000) X
20873         RETURN
20874       ENDIF
20875       KFA=IABS(KF)
20876       IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND.
20877      &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212
20878      &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND.
20879      &KFA.NE.3334.AND.KFA.NE.111) THEN
20880         WRITE(MSTU(11),5100) KF
20881         RETURN
20882       ENDIF
20883
20884 C...Electron parton distribution call.
20885       IF(KFA.EQ.11) THEN
20886         CALL PYPDEL(X,Q2,XPEL)
20887         DO 110 KFL=-25,25
20888           XPQ(KFL)=XPEL(KFL)
20889   110   CONTINUE
20890
20891 C...Photon parton distribution call (VDM+anomalous).
20892       ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
20893         IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
20894           CALL PYPDGA(X,Q2,XPGA)
20895           DO 120 KFL=-6,6
20896             XPQ(KFL)=XPGA(KFL)
20897   120     CONTINUE
20898         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
20899           Q2MX=Q2
20900           P2MX=0.36D0
20901           IF(MSTP(55).GE.7) P2MX=4.0D0
20902           IF(MSTP(57).EQ.0) Q2MX=P2MX
20903           CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20904           DO 130 KFL=-6,6
20905             XPQ(KFL)=XPGA(KFL)
20906   130     CONTINUE
20907           VINT(231)=P2MX
20908         ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
20909           Q2MX=Q2
20910           P2MX=0.36D0
20911           IF(MSTP(55).GE.11) P2MX=4.0D0
20912           IF(MSTP(57).EQ.0) Q2MX=P2MX
20913           CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA)
20914           DO 140 KFL=-6,6
20915             XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
20916   140     CONTINUE
20917           VINT(231)=P2MX
20918         ELSEIF(MSTP(56).EQ.2) THEN
20919 C...Call PDFLIB parton distributions.
20920           PARM(1)='NPTYPE'
20921           VALUE(1)=3
20922           PARM(2)='NGROUP'
20923           VALUE(2)=MSTP(55)/1000
20924           PARM(3)='NSET'
20925           VALUE(3)=MOD(MSTP(55),1000)
20926           IF(MINT(93).NE.3000000+MSTP(55)) THEN
20927             CALL PDFSET(PARM,VALUE)
20928             MINT(93)=3000000+MSTP(55)
20929           ENDIF
20930           XX=X
20931           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20932           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20933           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20934           VINT(231)=Q2MIN
20935           XPQ(0)=GLU
20936           XPQ(1)=DNV
20937           XPQ(-1)=DNV
20938           XPQ(2)=UPV
20939           XPQ(-2)=UPV
20940           XPQ(3)=STR
20941           XPQ(-3)=STR
20942           XPQ(4)=CHM
20943           XPQ(-4)=CHM
20944           XPQ(5)=BOT
20945           XPQ(-5)=BOT
20946           XPQ(6)=TOP
20947           XPQ(-6)=TOP
20948         ELSE
20949           WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
20950         ENDIF
20951
20952 C...Pion/gammaVDM parton distribution call.
20953       ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND.
20954      &  MINT(109).EQ.2)) THEN
20955         IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
20956      &  MSTP(55).LE.12) THEN
20957           ISET=1+MOD(MSTP(55)-1,4)
20958           Q2MX=Q2
20959           P2MX=0.36D0
20960           IF(ISET.GE.3) P2MX=4.0D0
20961           IF(MSTP(57).EQ.0) Q2MX=P2MX
20962           CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
20963           DO 150 KFL=-6,6
20964             XPQ(KFL)=XPGA(KFL)
20965   150     CONTINUE
20966           VINT(231)=P2MX
20967         ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
20968           CALL PYPDPI(X,Q2,XPPI)
20969           DO 160 KFL=-6,6
20970             XPQ(KFL)=XPPI(KFL)
20971   160     CONTINUE
20972         ELSEIF(MSTP(54).EQ.2) THEN
20973 C...Call PDFLIB parton distributions.
20974           PARM(1)='NPTYPE'
20975           VALUE(1)=2
20976           PARM(2)='NGROUP'
20977           VALUE(2)=MSTP(53)/1000
20978           PARM(3)='NSET'
20979           VALUE(3)=MOD(MSTP(53),1000)
20980           IF(MINT(93).NE.2000000+MSTP(53)) THEN
20981             CALL PDFSET(PARM,VALUE)
20982             MINT(93)=2000000+MSTP(53)
20983           ENDIF
20984           XX=X
20985           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
20986           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
20987           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
20988           VINT(231)=Q2MIN
20989           XPQ(0)=GLU
20990           XPQ(1)=DSEA
20991           XPQ(-1)=UPV+DSEA
20992           XPQ(2)=UPV+USEA
20993           XPQ(-2)=USEA
20994           XPQ(3)=STR
20995           XPQ(-3)=STR
20996           XPQ(4)=CHM
20997           XPQ(-4)=CHM
20998           XPQ(5)=BOT
20999           XPQ(-5)=BOT
21000           XPQ(6)=TOP
21001           XPQ(-6)=TOP
21002         ELSE
21003           WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
21004         ENDIF
21005
21006 C...Anomalous photon parton distribution call.
21007       ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
21008         Q2MX=Q2
21009         P2MX=PARP(15)**2
21010         IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
21011           IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
21012           IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
21013           IF(MSTP(57).EQ.0) Q2MX=P2MX
21014           CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21015           DO 170 KFL=-6,6
21016             XPQ(KFL)=XPGA(KFL)
21017   170     CONTINUE
21018           VINT(231)=P2MX
21019         ELSEIF(MSTP(56).EQ.1) THEN
21020           IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
21021           IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
21022           IF(MSTP(57).EQ.0) Q2MX=P2MX
21023           CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA)
21024           DO 180 KFL=-6,6
21025             XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
21026   180     CONTINUE
21027           VINT(231)=P2MX
21028         ELSEIF(MSTP(56).EQ.2) THEN
21029           IF(MSTP(57).EQ.0) Q2MX=P2MX
21030           CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
21031           DO 190 KFL=-6,6
21032             XPQ(KFL)=XPGA(KFL)
21033   190     CONTINUE
21034           VINT(231)=P2MX
21035         ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
21036           IF(MSTP(57).EQ.0) Q2MX=P2MX
21037           CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21038           DO 200 KFL=-6,6
21039             XPQ(KFL)=XPGA(KFL)
21040   200     CONTINUE
21041           VINT(231)=P2MX
21042         ELSE
21043   210     RKF=11D0*PYR(0)
21044           KFR=1
21045           IF(RKF.GT.1D0) KFR=2
21046           IF(RKF.GT.5D0) KFR=3
21047           IF(RKF.GT.6D0) KFR=4
21048           IF(RKF.GT.10D0) KFR=5
21049           IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210
21050           IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210
21051           IF(MSTP(57).EQ.0) Q2MX=P2MX
21052           CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
21053           DO 220 KFL=-6,6
21054             XPQ(KFL)=XPGA(KFL)
21055   220     CONTINUE
21056           VINT(231)=P2MX
21057         ENDIF
21058
21059 C...Proton parton distribution call.
21060       ELSE
21061         IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN
21062           CALL PYPDPR(X,Q2,XPPR)
21063           DO 230 KFL=-6,6
21064             XPQ(KFL)=XPPR(KFL)
21065   230     CONTINUE
21066         ELSEIF(MSTP(52).EQ.2) THEN
21067 C...Call PDFLIB parton distributions.
21068           PARM(1)='NPTYPE'
21069           VALUE(1)=1
21070           PARM(2)='NGROUP'
21071           VALUE(2)=MSTP(51)/1000
21072           PARM(3)='NSET'
21073           VALUE(3)=MOD(MSTP(51),1000)
21074           IF(MINT(93).NE.1000000+MSTP(51)) THEN
21075             CALL PDFSET(PARM,VALUE)
21076             MINT(93)=1000000+MSTP(51)
21077           ENDIF
21078           XX=X
21079           QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21080           IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21081           CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21082           VINT(231)=Q2MIN
21083           XPQ(0)=GLU
21084           XPQ(1)=DNV+DSEA
21085           XPQ(-1)=DSEA
21086           XPQ(2)=UPV+USEA
21087           XPQ(-2)=USEA
21088           XPQ(3)=STR
21089           XPQ(-3)=STR
21090           XPQ(4)=CHM
21091           XPQ(-4)=CHM
21092           XPQ(5)=BOT
21093           XPQ(-5)=BOT
21094           XPQ(6)=TOP
21095           XPQ(-6)=TOP
21096         ELSE
21097           WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
21098         ENDIF
21099       ENDIF
21100
21101 C...Isospin average for pi0/gammaVDM.
21102       IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
21103         IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
21104           XPV=XPQ(2)-XPQ(1)
21105           XPQ(2)=XPQ(1)
21106           XPQ(-2)=XPQ(-1)
21107         ELSE
21108           XPS=0.5D0*(XPQ(1)+XPQ(-2))
21109           XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
21110           XPQ(2)=XPS
21111           XPQ(-1)=XPS
21112         ENDIF
21113         IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
21114           XPQ(1)=XPQ(1)+0.2D0*XPV
21115           XPQ(-1)=XPQ(-1)+0.2D0*XPV
21116           XPQ(2)=XPQ(2)+0.8D0*XPV
21117           XPQ(-2)=XPQ(-2)+0.8D0*XPV
21118         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
21119           XPQ(3)=XPQ(3)+XPV
21120           XPQ(-3)=XPQ(-3)+XPV
21121         ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
21122           XPQ(4)=XPQ(4)+XPV
21123           XPQ(-4)=XPQ(-4)+XPV
21124           IF(MSTP(55).GE.9) THEN
21125             DO 240 KFL=-6,6
21126               XPQ(KFL)=0D0
21127   240       CONTINUE
21128           ENDIF
21129         ELSE
21130           XPQ(1)=XPQ(1)+0.5D0*XPV
21131           XPQ(-1)=XPQ(-1)+0.5D0*XPV
21132           XPQ(2)=XPQ(2)+0.5D0*XPV
21133           XPQ(-2)=XPQ(-2)+0.5D0*XPV
21134         ENDIF
21135
21136 C...Rescale for gammaVDM by effective gamma -> rho coupling.
21137         IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
21138           DO 250 KFL=-6,6
21139             XPQ(KFL)=VINT(281)*XPQ(KFL)
21140   250     CONTINUE
21141           VINT(232)=VINT(281)*XPV
21142         ENDIF
21143
21144 C...Isospin conjugation for neutron.
21145       ELSEIF(KFA.EQ.2112) THEN
21146         XPS=XPQ(1)
21147         XPQ(1)=XPQ(2)
21148         XPQ(2)=XPS
21149         XPS=XPQ(-1)
21150         XPQ(-1)=XPQ(-2)
21151         XPQ(-2)=XPS
21152
21153 C...Simple recipes for hyperon (average valence parton distribution).
21154       ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
21155      &  .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
21156         XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
21157         XPSEA=0.5D0*(XPQ(-1)+XPQ(-2))
21158         XPQ(1)=XPSEA
21159         XPQ(2)=XPSEA
21160         XPQ(-1)=XPSEA
21161         XPQ(-2)=XPSEA
21162         XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL
21163         XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL
21164         XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL
21165       ENDIF
21166
21167 C...Charge conjugation for antiparticle.
21168       IF(KF.LT.0) THEN
21169         DO 260 KFL=1,25
21170           IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260
21171           XPS=XPQ(KFL)
21172           XPQ(KFL)=XPQ(-KFL)
21173           XPQ(-KFL)=XPS
21174   260   CONTINUE
21175       ENDIF
21176
21177 C...Allow gluon also in position 21.
21178       XPQ(21)=XPQ(0)
21179
21180 C...Check positivity and reset above maximum allowed flavour.
21181       DO 270 KFL=-25,25
21182         XPQ(KFL)=MAX(0D0,XPQ(KFL))
21183         IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
21184   270 CONTINUE
21185
21186 C...Formats for error printouts.
21187  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21188  5100 FORMAT(' Error: illegal particle code for parton distribution;',
21189      &' KF =',I5)
21190  5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
21191      &3I5)
21192
21193       RETURN
21194       END
21195
21196 C*********************************************************************
21197
21198 *$ CREATE PYPDFL.FOR
21199 *COPY PYPDFL
21200 C...PYPDFL
21201 C...Gives proton parton distribution at small x and/or Q^2 according to
21202 C...correct limiting behaviour.
21203
21204       SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
21205
21206 C...Double precision and integer declarations.
21207       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21208       INTEGER PYK,PYCHGE,PYCOMP
21209 C...Commonblocks.
21210       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21211       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21212       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21213       COMMON/PYINT1/MINT(400),VINT(400)
21214       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21215 C...Local arrays.
21216       DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
21217       DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
21218
21219 C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
21220       MINT(92)=0
21221       KFA=IABS(KF)
21222       IACC=0
21223       IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
21224       IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
21225       IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
21226       IF(IACC.EQ.0) THEN
21227         CALL PYPDFU(KF,X,Q2,XPQ)
21228         RETURN
21229       ENDIF
21230
21231 C...Reset. Check x.
21232       DO 100 KFL=-25,25
21233         XPQ(KFL)=0D0
21234   100 CONTINUE
21235       IF(X.LE.0D0.OR.X.GE.1D0) THEN
21236         WRITE(MSTU(11),5000) X
21237         RETURN
21238       ENDIF
21239
21240 C...Define valence content.
21241       KFC=KF
21242       NV1=2
21243       NV2=1
21244       IF(KF.EQ.2212) THEN
21245         KFV1=2
21246         KFV2=1
21247       ELSEIF(KF.EQ.-2212) THEN
21248         KFV1=-2
21249         KFV2=-1
21250       ELSEIF(KF.EQ.2112) THEN
21251         KFV1=1
21252         KFV2=2
21253       ELSEIF(KF.EQ.-2112) THEN
21254         KFV1=-1
21255         KFV2=-2
21256       ELSEIF(KF.EQ.211) THEN
21257         NV1=1
21258         KFV1=2
21259         KFV2=-1
21260       ELSEIF(KF.EQ.-211) THEN
21261         NV1=1
21262         KFV1=-2
21263         KFV2=1
21264       ELSEIF(MINT(105).LE.223) THEN
21265         KFV1=1
21266         WTV1=0.2D0
21267         KFV2=2
21268         WTV2=0.8D0
21269       ELSEIF(MINT(105).EQ.333) THEN
21270         KFV1=3
21271         WTV1=1.0D0
21272         KFV2=1
21273         WTV2=0.0D0
21274       ELSEIF(MINT(105).EQ.443) THEN
21275         KFV1=4
21276         WTV1=1.0D0
21277         KFV2=1
21278         WTV2=0.0D0
21279       ENDIF
21280
21281 C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
21282       CALL PYPDFU(KFC,X,Q2,XPA)
21283       Q2MN=MAX(3D0,VINT(231))
21284       Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
21285       XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
21286
21287 C...Large Q2 and large x: naive call is enough.
21288       IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
21289         DO 110 KFL=-25,25
21290           XPQ(KFL)=XPA(KFL)
21291   110   CONTINUE
21292         MINT(92)=1
21293
21294 C...Small Q2 and large x: dampen boundary value.
21295       ELSEIF(X.GT.XMN) THEN
21296
21297 C...Evaluate at boundary and define dampening factors.
21298         CALL PYPDFU(KFC,X,Q2MN,XPA)
21299         FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
21300         FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
21301
21302 C...Separate valence and sea parts of parton distribution.
21303         IF(KFA.NE.22) THEN
21304           XFV1=XPA(KFV1)-XPA(-KFV1)
21305           XPA(KFV1)=XPA(-KFV1)
21306           XFV2=XPA(KFV2)-XPA(-KFV2)
21307           XPA(KFV2)=XPA(-KFV2)
21308         ELSE
21309           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21310           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21311           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21312           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21313         ENDIF
21314
21315 C...Dampen valence and sea separately. Put back together.
21316         DO 120 KFL=-25,25
21317           XPQ(KFL)=FS*XPA(KFL)
21318   120   CONTINUE
21319         IF(KFA.NE.22) THEN
21320           XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
21321           XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
21322         ELSE
21323           XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
21324           XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
21325           XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
21326           XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
21327         ENDIF
21328         MINT(92)=2
21329
21330 C...Large Q2 and small x: interpolate behaviour.
21331       ELSEIF(Q2.GT.Q2MN) THEN
21332
21333 C...Evaluate at extremes and define coefficients for interpolation.
21334         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21335         VI232A=VINT(232)
21336         CALL PYPDFU(KFC,X,Q2B,XPB)
21337         VI232B=VINT(232)
21338         FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
21339         FVA=(X/XMN)**0.45D0*FLA
21340         FSA=(X/XMN)**(-0.08D0)*FLA
21341         FB=1D0-FLA
21342
21343 C...Separate valence and sea parts of parton distribution.
21344         IF(KFA.NE.22) THEN
21345           XFVA1=XPA(KFV1)-XPA(-KFV1)
21346           XPA(KFV1)=XPA(-KFV1)
21347           XFVA2=XPA(KFV2)-XPA(-KFV2)
21348           XPA(KFV2)=XPA(-KFV2)
21349           XFVB1=XPB(KFV1)-XPB(-KFV1)
21350           XPB(KFV1)=XPB(-KFV1)
21351           XFVB2=XPB(KFV2)-XPB(-KFV2)
21352           XPB(KFV2)=XPB(-KFV2)
21353         ELSE
21354           XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
21355           XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
21356           XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
21357           XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
21358           XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
21359           XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
21360           XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
21361           XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
21362         ENDIF
21363
21364 C...Interpolate for valence and sea. Put back together.
21365         DO 130 KFL=-25,25
21366           XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
21367   130   CONTINUE
21368         IF(KFA.NE.22) THEN
21369           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
21370           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
21371         ELSE
21372           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21373           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
21374           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21375           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
21376         ENDIF
21377         MINT(92)=3
21378
21379 C...Small Q2 and small x: dampen boundary value and add term.
21380       ELSE
21381
21382 C...Evaluate at boundary and define dampening factors.
21383         CALL PYPDFU(KFC,XMN,Q2MN,XPA)
21384         FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
21385         FA=1D0-FB
21386         FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
21387         FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
21388         FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
21389         FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
21390         FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
21391         FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
21392
21393 C...Separate valence and sea parts of parton distribution.
21394         IF(KFA.NE.22) THEN
21395           XFV1=XPA(KFV1)-XPA(-KFV1)
21396           XPA(KFV1)=XPA(-KFV1)
21397           XFV2=XPA(KFV2)-XPA(-KFV2)
21398           XPA(KFV2)=XPA(-KFV2)
21399         ELSE
21400           XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
21401           XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
21402           XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
21403           XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
21404         ENDIF
21405
21406 C...Dampen valence and sea separately. Add constant terms.
21407 C...Put back together.
21408         DO 140 KFL=-25,25
21409           XPQ(KFL)=FSA*XPA(KFL)
21410   140   CONTINUE
21411         IF(KFA.NE.22) THEN
21412           DO 150 KFL=-3,3
21413             XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
21414   150     CONTINUE
21415           XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
21416           XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
21417         ELSE
21418           DO 160 KFL=-3,3
21419             XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
21420   160     CONTINUE
21421           XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21422           XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
21423           XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21424           XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
21425         ENDIF
21426         XPQ(21)=XPQ(0)
21427         MINT(92)=4
21428       ENDIF
21429
21430 C...Format for error printout.
21431  5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
21432
21433       RETURN
21434       END
21435
21436 C*********************************************************************
21437
21438 *$ CREATE PYPDEL.FOR
21439 *COPY PYPDEL
21440 C...PYPDEL
21441 C...Gives electron parton distribution.
21442
21443       SUBROUTINE PYPDEL(X,Q2,XPEL)
21444
21445 C...Double precision and integer declarations.
21446       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21447       INTEGER PYK,PYCHGE,PYCOMP
21448 C...Commonblocks.
21449       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21450       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21451       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21452       COMMON/PYINT1/MINT(400),VINT(400)
21453       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
21454 C...Local arrays.
21455       DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
21456
21457 C...Interface to PDFLIB.
21458       COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
21459       SAVE /W50513/
21460       DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
21461      &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
21462       CHARACTER*20 PARM(20)
21463       DATA VALUE/20*0D0/,PARM/20*' '/
21464
21465 C...Some common constants.
21466       DO 100 KFL=-25,25
21467         XPEL(KFL)=0D0
21468   100 CONTINUE
21469       AEM=PARU(101)
21470       PME=PMAS(11,1)
21471       XL=LOG(MAX(1D-10,X))
21472       X1L=LOG(MAX(1D-10,1D0-X))
21473       HLE=LOG(MAX(3D0,Q2/PME**2))
21474       HBE2=(AEM/PARU(1))*(HLE-1D0)
21475
21476 C...Electron inside electron, see R. Kleiss et al., in Z physics at
21477 C...LEP 1, CERN 89-08, p. 34
21478       IF(MSTP(59).LE.1) THEN
21479         HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
21480      &  (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
21481         HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
21482      &  0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
21483      &  4D0*XL/(1D0-X)-5D0-X)
21484       ELSE
21485         HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
21486      &  PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
21487      &  (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
21488       ENDIF
21489       IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN
21490         HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0)
21491       ELSEIF(X.GT.0.999999D0) THEN
21492         HEE=0D0
21493       ENDIF
21494       XPEL(11)=X*HEE
21495
21496 C...Photon and (transverse) W- inside electron.
21497       AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
21498       IF(MSTP(13).LE.1) THEN
21499         HLG=HLE
21500       ELSE
21501         HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
21502       ENDIF
21503       XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
21504       HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
21505       XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
21506
21507 C...Electron or positron inside photon inside electron.
21508       IF(MSTP(12).EQ.1) THEN
21509         XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
21510      &  2D0*X*(1D0+X)*XL)
21511         XPEL(11)=XPEL(11)+XFSEA
21512         XPEL(-11)=XFSEA
21513
21514 C...Initialize PDFLIB photon parton distributions.
21515         IF(MSTP(56).EQ.2) THEN
21516           PARM(1)='NPTYPE'
21517           VALUE(1)=3
21518           PARM(2)='NGROUP'
21519           VALUE(2)=MSTP(55)/1000
21520           PARM(3)='NSET'
21521           VALUE(3)=MOD(MSTP(55),1000)
21522           IF(MINT(93).NE.3000000+MSTP(55)) THEN
21523             CALL PDFSET(PARM,VALUE)
21524             MINT(93)=3000000+MSTP(55)
21525           ENDIF
21526         ENDIF
21527
21528 C...Quarks and gluons inside photon inside electron:
21529 C...numerical convolution required.
21530         DO 110 KFL=0,6
21531           SXP(KFL)=0D0
21532   110   CONTINUE
21533         SUMXPP=0D0
21534         ITER=-1
21535   120   ITER=ITER+1
21536         SUMXP=SUMXPP
21537         NSTP=2**(ITER-1)
21538         IF(ITER.EQ.0) NSTP=2
21539         DO 130 KFL=0,6
21540           SXP(KFL)=0.5D0*SXP(KFL)
21541   130   CONTINUE
21542         WTSTP=0.5D0/NSTP
21543         IF(ITER.EQ.0) WTSTP=0.5D0
21544 C...Pick grid of x_{gamma} values logarithmically even.
21545         DO 150 ISTP=1,NSTP
21546           IF(ITER.EQ.0) THEN
21547             XLE=XL*(ISTP-1)
21548           ELSE
21549             XLE=XL*(ISTP-0.5D0)/NSTP
21550           ENDIF
21551           XE=MIN(0.999999D0,EXP(XLE))
21552           XG=MIN(0.999999D0,X/XE)
21553 C...Evaluate photon inside electron parton distribution for convolution.
21554           XPGP=1D0+(1D0-XE)**2
21555           IF(MSTP(13).LE.1) THEN
21556             XPGP=XPGP*HLE
21557           ELSE
21558             XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
21559           ENDIF
21560 C...Evaluate photon parton distributions for convolution.
21561           IF(MSTP(56).EQ.1) THEN
21562             CALL PYPDGA(XG,Q2,XPGA)
21563             DO 140 KFL=0,5
21564               SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
21565   140       CONTINUE
21566           ELSEIF(MSTP(56).EQ.2) THEN
21567 C...Call PDFLIB parton distributions.
21568             XX=XG
21569             QQ=SQRT(MAX(0D0,Q2MIN,Q2))
21570             IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
21571             CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
21572             SXP(0)=SXP(0)+WTSTP*XPGP*GLU
21573             SXP(1)=SXP(1)+WTSTP*XPGP*DNV
21574             SXP(2)=SXP(2)+WTSTP*XPGP*UPV
21575             SXP(3)=SXP(3)+WTSTP*XPGP*STR
21576             SXP(4)=SXP(4)+WTSTP*XPGP*CHM
21577             SXP(5)=SXP(5)+WTSTP*XPGP*BOT
21578             SXP(6)=SXP(6)+WTSTP*XPGP*TOP
21579           ENDIF
21580   150   CONTINUE
21581         SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
21582         IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
21583      &  PARP(14)*(SUMXPP+SUMXP))) GOTO 120
21584
21585 C...Put convolution into output arrays.
21586         FCONV=AEMP*(-XL)
21587         XPEL(0)=FCONV*SXP(0)
21588         DO 160 KFL=1,6
21589           XPEL(KFL)=FCONV*SXP(KFL)
21590           XPEL(-KFL)=XPEL(KFL)
21591   160   CONTINUE
21592       ENDIF
21593
21594       RETURN
21595       END
21596
21597 C*********************************************************************
21598
21599 *$ CREATE PYPDGA.FOR
21600 *COPY PYPDGA
21601 C...PYPDGA
21602 C...Gives photon parton distribution.
21603
21604       SUBROUTINE PYPDGA(X,Q2,XPGA)
21605
21606 C...Double precision and integer declarations.
21607       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21608       INTEGER PYK,PYCHGE,PYCOMP
21609 C...Commonblocks.
21610       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21611       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21612       COMMON/PYINT1/MINT(400),VINT(400)
21613       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
21614 C...Local arrays.
21615       DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
21616      &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
21617      &DGCS(4,3),DGDS(4,3),DGES(4,3)
21618
21619 C...The following data lines are coefficients needed in the
21620 C...Drees and Grassie photon parton distribution parametrization.
21621       DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
21622      &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
21623       DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
21624      &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
21625       DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
21626      &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
21627       DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
21628      &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
21629       DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
21630      &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
21631       DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
21632      &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
21633       DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
21634      &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
21635       DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
21636      &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
21637       DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
21638      &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
21639       DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
21640      &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
21641       DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
21642      &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
21643       DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
21644      &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
21645       DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
21646      &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
21647
21648 C...Photon parton distribution from Drees and Grassie.
21649 C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
21650       DO 100 KFL=-6,6
21651         XPGA(KFL)=0D0
21652   100 CONTINUE
21653       VINT(231)=1D0
21654       IF(MSTP(57).LE.0) THEN
21655         T=LOG(1D0/0.16D0)
21656       ELSE
21657         T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
21658       ENDIF
21659       X1=1D0-X
21660       NF=3
21661       IF(Q2.GT.25D0) NF=4
21662       IF(Q2.GT.300D0) NF=5
21663       NFE=NF-2
21664       AEM=PARU(101)
21665
21666 C...Evaluate gluon content.
21667       DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
21668       DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
21669       DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
21670       XPGL=DGA*X**DGB*X1**DGC
21671
21672 C...Evaluate up- and down-type quark content.
21673       DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
21674       DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
21675       DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
21676       DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
21677       DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
21678       XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21679       DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
21680       DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
21681       DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
21682       DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
21683       DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
21684       DGF=9D0
21685       IF(NF.EQ.4) DGF=10D0
21686       IF(NF.EQ.5) DGF=55D0/6D0
21687       XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
21688       IF(NF.LE.3) THEN
21689         XPQU=(XPQS+9D0*XPQN)/6D0
21690         XPQD=(XPQS-4.5D0*XPQN)/6D0
21691       ELSEIF(NF.EQ.4) THEN
21692         XPQU=(XPQS+6D0*XPQN)/8D0
21693         XPQD=(XPQS-6D0*XPQN)/8D0
21694       ELSE
21695         XPQU=(XPQS+7.5D0*XPQN)/10D0
21696         XPQD=(XPQS-5D0*XPQN)/10D0
21697       ENDIF
21698
21699 C...Put into output arrays.
21700       XPGA(0)=AEM*XPGL
21701       XPGA(1)=AEM*XPQD
21702       XPGA(2)=AEM*XPQU
21703       XPGA(3)=AEM*XPQD
21704       IF(NF.GE.4) XPGA(4)=AEM*XPQU
21705       IF(NF.GE.5) XPGA(5)=AEM*XPQD
21706       DO 110 KFL=1,6
21707         XPGA(-KFL)=XPGA(KFL)
21708   110 CONTINUE
21709
21710       RETURN
21711       END
21712
21713 C*********************************************************************
21714
21715 *$ CREATE PYGGAM.FOR
21716 *COPY PYGGAM
21717 C...PYGGAM
21718 C...Constructs the F2 and parton distributions of the photon
21719 C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
21720 C...For F2, c and b are included by the Bethe-Heitler formula;
21721 C...in the 'MSbar' scheme additionally a Cgamma term is added.
21722 C...Contains the SaS sets 1D, 1M, 2D and 2M.
21723 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21724
21725       SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
21726
21727 C...Double precision and integer declarations.
21728       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21729       INTEGER PYK,PYCHGE,PYCOMP
21730 C...Commonblocks.
21731       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
21732      &XPDIR(-6:6)
21733       COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
21734       SAVE /PYINT8/,/PYINT9/
21735 C...Local arrays.
21736       DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
21737 C...Charm and bottom masses (low to compensate for J/psi etc.).
21738       DATA PMC/1.3D0/, PMB/4.6D0/
21739 C...alpha_em and alpha_em/(2*pi).
21740       DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
21741 C...Lambda value for 4 flavours.
21742       DATA ALAM/0.20D0/
21743 C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
21744       DATA FRACU/0.8D0/
21745 C...VMD couplings f_V**2/(4*pi).
21746       DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
21747 C...Masses for rho (=omega) and phi.
21748       DATA PMRHO/0.770D0/, PMPHI/1.020D0/
21749 C...Number of points in integration for IP2=1.
21750       DATA NSTEP/100/
21751
21752 C...Reset output.
21753       F2GM=0D0
21754       DO 100 KFL=-6,6
21755         XPDFGM(KFL)=0D0
21756         XPVMD(KFL)=0D0
21757         XPANL(KFL)=0D0
21758         XPANH(KFL)=0D0
21759         XPBEH(KFL)=0D0
21760         XPDIR(KFL)=0D0
21761         VXPVMD(KFL)=0D0
21762         VXPANL(KFL)=0D0
21763         VXPANH(KFL)=0D0
21764         VXPDGM(KFL)=0D0
21765   100 CONTINUE
21766
21767 C...Set Q0 cut-off parameter as function of set used.
21768       IF(ISET.LE.2) THEN
21769         Q0=0.6D0
21770       ELSE
21771         Q0=2D0
21772       ENDIF
21773       Q02=Q0**2
21774
21775 C...Scale choice for off-shell photon; common factors.
21776       Q2A=Q2
21777       FACNOR=1D0
21778       IF(IP2.EQ.1) THEN
21779         P2MX=P2+Q02
21780         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21781         FACNOR=LOG(Q2/Q02)/NSTEP
21782       ELSEIF(IP2.EQ.2) THEN
21783         P2MX=MAX(P2,Q02)
21784       ELSEIF(IP2.EQ.3) THEN
21785         P2MX=P2+Q02
21786         Q2A=Q2+P2*Q02/MAX(Q02,Q2)
21787       ELSEIF(IP2.EQ.4) THEN
21788         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21789      &  ((Q2+P2)*(Q02+P2)))
21790       ELSEIF(IP2.EQ.5) THEN
21791         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21792      &  ((Q2+P2)*(Q02+P2)))
21793         P2MX=Q0*SQRT(P2MXA)
21794         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
21795       ELSEIF(IP2.EQ.6) THEN
21796         P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21797      &  ((Q2+P2)*(Q02+P2)))
21798         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21799       ELSE
21800         P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
21801      &  ((Q2+P2)*(Q02+P2)))
21802         P2MX=Q0*SQRT(P2MXA)
21803         P2MXB=P2MX
21804         P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
21805         P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
21806         FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
21807       ENDIF
21808
21809 C...Call VMD parametrization for d quark and use to give rho, omega,
21810 C...phi. Note dipole dampening for off-shell photon.
21811       CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21812       XFVAL=VXPGA(1)
21813       XPGA(1)=XPGA(2)
21814       XPGA(-1)=XPGA(-2)
21815       FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
21816       FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
21817       DO 110 KFL=-5,5
21818         XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
21819   110 CONTINUE
21820       XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
21821       XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
21822       XPVMD(3)=XPVMD(3)+FACS*XFVAL
21823       XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
21824       XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
21825       XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
21826       VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
21827       VXPVMD(2)=FRACU*FACUD*XFVAL
21828       VXPVMD(3)=FACS*XFVAL
21829       VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
21830       VXPVMD(-2)=FRACU*FACUD*XFVAL
21831       VXPVMD(-3)=FACS*XFVAL
21832
21833       IF(IP2.NE.1) THEN
21834 C...Anomalous parametrizations for different strategies
21835 C...for off-shell photons; except full integration.
21836
21837 C...Call anomalous parametrization for d + u + s.
21838         CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21839         DO 120 KFL=-5,5
21840           XPANL(KFL)=FACNOR*XPGA(KFL)
21841           VXPANL(KFL)=FACNOR*VXPGA(KFL)
21842   120   CONTINUE
21843
21844 C...Call anomalous parametrization for c and b.
21845         CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21846         DO 130 KFL=-5,5
21847           XPANH(KFL)=FACNOR*XPGA(KFL)
21848           VXPANH(KFL)=FACNOR*VXPGA(KFL)
21849   130   CONTINUE
21850         CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
21851         DO 140 KFL=-5,5
21852           XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
21853           VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
21854   140   CONTINUE
21855
21856       ELSE
21857 C...Special option: loop over flavours and integrate over k2.
21858         DO 170 KF=1,5
21859           DO 160 ISTEP=1,NSTEP
21860             Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
21861             IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
21862      &      (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
21863             CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
21864             FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
21865             IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
21866             IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
21867             DO 150 KFL=-5,5
21868               IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
21869               IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
21870               IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
21871               IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
21872   150       CONTINUE
21873   160     CONTINUE
21874   170   CONTINUE
21875       ENDIF
21876
21877 C...Call Bethe-Heitler term expression for charm and bottom.
21878       CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
21879       XPBEH(4)=XPBH
21880       XPBEH(-4)=XPBH
21881       CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
21882       XPBEH(5)=XPBH
21883       XPBEH(-5)=XPBH
21884
21885 C...For MSbar subtraction call C^gamma term expression for d, u, s.
21886       IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
21887         CALL PYGDIR(X,Q2,P2,Q02,XPGA)
21888         DO 180 KFL=-5,5
21889           XPDIR(KFL)=XPGA(KFL)
21890   180   CONTINUE
21891       ENDIF
21892
21893 C...Store result in output array.
21894       DO 190 KFL=-5,5
21895         CHSQ=1D0/9D0
21896         IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
21897         XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
21898         IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
21899         XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
21900         VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
21901   190 CONTINUE
21902
21903       RETURN
21904       END
21905
21906 C*********************************************************************
21907
21908 *$ CREATE PYGVMD.FOR
21909 *COPY PYGVMD
21910 C...PYGVMD
21911 C...Evaluates the VMD parton distributions of a photon,
21912 C...evolved homogeneously from an initial scale P2 to Q2.
21913 C...Does not include dipole suppression factor.
21914 C...ISET is parton distribution set, see above;
21915 C...additionally ISET=0 is used for the evolution of an anomalous photon
21916 C...which branched at a scale P2 and then evolved homogeneously to Q2.
21917 C...ALAM is the 4-flavour Lambda, which is automatically converted
21918 C...to 3- and 5-flavour equivalents as needed.
21919 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
21920
21921       SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
21922
21923 C...Double precision and integer declarations.
21924       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21925       INTEGER PYK,PYCHGE,PYCOMP
21926 C...Local arrays and data.
21927       DIMENSION XPGA(-6:6), VXPGA(-6:6)
21928       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
21929
21930 C...Reset output.
21931       DO 100 KFL=-6,6
21932         XPGA(KFL)=0D0
21933         VXPGA(KFL)=0D0
21934   100 CONTINUE
21935       KFA=IABS(KF)
21936
21937 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
21938       ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
21939       ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
21940       P2EFF=MAX(P2,1.2D0*ALAM3**2)
21941       IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
21942       IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
21943       Q2EFF=MAX(Q2,P2EFF)
21944
21945 C...Find number of flavours at lower and upper scale.
21946       NFP=4
21947       IF(P2EFF.LT.PMC**2) NFP=3
21948       IF(P2EFF.GT.PMB**2) NFP=5
21949       NFQ=4
21950       IF(Q2EFF.LT.PMC**2) NFQ=3
21951       IF(Q2EFF.GT.PMB**2) NFQ=5
21952
21953 C...Find s as sum of 3-, 4- and 5-flavour parts.
21954       S=0D0
21955       IF(NFP.EQ.3) THEN
21956         Q2DIV=PMC**2
21957         IF(NFQ.EQ.3) Q2DIV=Q2EFF
21958         S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
21959       ENDIF
21960       IF(NFP.LE.4.AND.NFQ.GE.4) THEN
21961         P2DIV=P2EFF
21962         IF(NFP.EQ.3) P2DIV=PMC**2
21963         Q2DIV=Q2EFF
21964         IF(NFQ.EQ.5) Q2DIV=PMB**2
21965         S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
21966       ENDIF
21967       IF(NFQ.EQ.5) THEN
21968         P2DIV=PMB**2
21969         IF(NFP.EQ.5) P2DIV=P2EFF
21970         S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
21971       ENDIF
21972
21973 C...Calculate frequent combinations of x and s.
21974       X1=1D0-X
21975       XL=-LOG(X)
21976       S2=S**2
21977       S3=S**3
21978       S4=S**4
21979
21980 C...Evaluate homogeneous anomalous parton distributions below or
21981 C...above threshold.
21982       IF(ISET.EQ.0) THEN
21983         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
21984      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
21985           XVAL = X * 1.5D0 * (X**2+X1**2)
21986           XGLU = 0D0
21987           XSEA = 0D0
21988         ELSE
21989           XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
21990      &    (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
21991      &    5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
21992      &    X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
21993           XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
21994      &    X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
21995      &    ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
21996           XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
21997      &    X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
21998      &    ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
21999      &    (2D0*X-1D0)*X*XL**2)
22000         ENDIF
22001
22002 C...Evaluate set 1D parton distributions below or above threshold.
22003       ELSEIF(ISET.EQ.1) THEN
22004         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22005      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22006           XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
22007           XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
22008           XSEA = 0.100D0 * X1**3.76D0
22009         ELSE
22010           XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
22011      &    X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
22012           XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
22013      &    X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
22014      &    XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
22015      &    X**0.40D0 * X1**(1.76D0+3D0*S)
22016           XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
22017      &    (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
22018      &    X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
22019           XSEA0 = 0.100D0 * X1**3.76D0
22020         ENDIF
22021
22022 C...Evaluate set 1M parton distributions below or above threshold.
22023       ELSEIF(ISET.EQ.2) THEN
22024         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22025      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22026           XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
22027           XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
22028           XSEA = 0D0
22029         ELSE
22030           XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
22031      &    X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
22032           XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
22033      &    EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
22034      &    X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
22035      &    EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
22036           XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
22037      &    X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
22038      &    XL**(2.8D0*S)
22039           XSEA0 = 0D0
22040         ENDIF
22041
22042 C...Evaluate set 2D parton distributions below or above threshold.
22043       ELSEIF(ISET.EQ.3) THEN
22044         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22045      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22046           XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
22047           XGLU = 1.925D0 * X1**2
22048           XSEA = 0.242D0 * X1**4
22049         ELSE
22050           XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
22051      &    X**(0.46D0+0.25D0*S) *
22052      &    X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
22053      &    (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
22054           XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
22055      &    EXP(-18.67D0*S) *
22056      &    X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
22057      &    * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
22058      &    XL**(9.3D0*S/(1D0+1.7D0*S))
22059           XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
22060      &    (1D0-0.607D0*S+21.95D0*S2) *
22061      &    X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
22062           XSEA0 = 0.242D0 * X1**4
22063         ENDIF
22064
22065 C...Evaluate set 2M parton distributions below or above threshold.
22066       ELSEIF(ISET.EQ.4) THEN
22067         IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
22068      &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
22069           XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
22070           XGLU = 1.808D0 * X1**2
22071           XSEA = 0.209D0 * X1**4
22072         ELSE
22073           XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
22074      &    X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
22075      &    X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
22076      &    XL**(5.15D0*S/(1D0+2D0*S)) +
22077      &    (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
22078           XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
22079      &    X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
22080      &    X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
22081      &    XL**(10.9D0*S/(1D0+2.5D0*S))
22082           XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
22083      &    X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
22084      &    X1**(4D0+S) * XL**(0.45D0*S)
22085           XSEA0 = 0.209D0 * X1**4
22086         ENDIF
22087       ENDIF
22088
22089 C...Threshold factors for c and b sea.
22090       SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22091       XCHM=0D0
22092       IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22093         SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22094         IF(ISET.EQ.0) THEN
22095           XCHM=XSEA*(1D0-(SCH/SLL)**2)
22096         ELSE
22097           XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
22098         ENDIF
22099       ENDIF
22100       XBOT=0D0
22101       IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22102         SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22103         IF(ISET.EQ.0) THEN
22104           XBOT=XSEA*(1D0-(SBT/SLL)**2)
22105         ELSE
22106           XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
22107         ENDIF
22108       ENDIF
22109
22110 C...Fill parton distributions.
22111       XPGA(0)=XGLU
22112       XPGA(1)=XSEA
22113       XPGA(2)=XSEA
22114       XPGA(3)=XSEA
22115       XPGA(4)=XCHM
22116       XPGA(5)=XBOT
22117       XPGA(KFA)=XPGA(KFA)+XVAL
22118       DO 110 KFL=1,5
22119         XPGA(-KFL)=XPGA(KFL)
22120   110 CONTINUE
22121       VXPGA(KFA)=XVAL
22122       VXPGA(-KFA)=XVAL
22123
22124       RETURN
22125       END
22126
22127 C*********************************************************************
22128
22129 *$ CREATE PYGANO.FOR
22130 *COPY PYGANO
22131 C...PYGANO
22132 C...Evaluates the parton distributions of the anomalous photon,
22133 C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
22134 C...KF=0 gives the sum over (up to) 5 flavours,
22135 C...KF<0 limits to flavours up to abs(KF),
22136 C...KF>0 is for flavour KF only.
22137 C...ALAM is the 4-flavour Lambda, which is automatically converted
22138 C...to 3- and 5-flavour equivalents as needed.
22139 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22140
22141       SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
22142
22143 C...Double precision and integer declarations.
22144       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22145       INTEGER PYK,PYCHGE,PYCOMP
22146 C...Local arrays and data.
22147       DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
22148       DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
22149
22150 C...Reset output.
22151       DO 100 KFL=-6,6
22152         XPGA(KFL)=0D0
22153         VXPGA(KFL)=0D0
22154   100 CONTINUE
22155       IF(Q2.LE.P2) RETURN
22156       KFA=IABS(KF)
22157
22158 C...Calculate Lambda; protect against unphysical Q2 and P2 input.
22159       ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
22160       ALAMSQ(4)=ALAM**2
22161       ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
22162       P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
22163       IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
22164       IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
22165       Q2EFF=MAX(Q2,P2EFF)
22166       XL=-LOG(X)
22167
22168 C...Find number of flavours at lower and upper scale.
22169       NFP=4
22170       IF(P2EFF.LT.PMC**2) NFP=3
22171       IF(P2EFF.GT.PMB**2) NFP=5
22172       NFQ=4
22173       IF(Q2EFF.LT.PMC**2) NFQ=3
22174       IF(Q2EFF.GT.PMB**2) NFQ=5
22175
22176 C...Define range of flavour loop.
22177       IF(KF.EQ.0) THEN
22178         KFLMN=1
22179         KFLMX=5
22180       ELSEIF(KF.LT.0) THEN
22181         KFLMN=1
22182         KFLMX=KFA
22183       ELSE
22184         KFLMN=KFA
22185         KFLMX=KFA
22186       ENDIF
22187
22188 C...Loop over flavours the photon can branch into.
22189       DO 110 KFL=KFLMN,KFLMX
22190
22191 C...Light flavours: calculate t range and (approximate) s range.
22192         IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
22193           TDIFF=LOG(Q2EFF/P2EFF)
22194           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22195      &    LOG(P2EFF/ALAMSQ(NFQ)))
22196           IF(NFQ.GT.NFP) THEN
22197             Q2DIV=PMB**2
22198             IF(NFQ.EQ.4) Q2DIV=PMC**2
22199             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22200      &      LOG(P2EFF/ALAMSQ(NFQ)))
22201             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22202      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
22203             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22204           ENDIF
22205           IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
22206             Q2DIV=PMC**2
22207             SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
22208      &      LOG(P2EFF/ALAMSQ(4)))
22209             SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
22210      &      LOG(P2EFF/ALAMSQ(3)))
22211             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
22212           ENDIF
22213
22214 C...u and s quark do not need a separate treatment when d has been done.
22215         ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
22216
22217 C...Charm: as above, but only include range above c threshold.
22218         ELSEIF(KFL.EQ.4) THEN
22219           IF(Q2.LE.PMC**2) GOTO 110
22220           P2EFF=MAX(P2EFF,PMC**2)
22221           Q2EFF=MAX(Q2EFF,P2EFF)
22222           TDIFF=LOG(Q2EFF/P2EFF)
22223           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22224      &    LOG(P2EFF/ALAMSQ(NFQ)))
22225           IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
22226             Q2DIV=PMB**2
22227             SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
22228      &      LOG(P2EFF/ALAMSQ(NFQ)))
22229             SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
22230      &      LOG(P2EFF/ALAMSQ(NFQ-1)))
22231             S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
22232           ENDIF
22233
22234 C...Bottom: as above, but only include range above b threshold.
22235         ELSEIF(KFL.EQ.5) THEN
22236           IF(Q2.LE.PMB**2) GOTO 110
22237           P2EFF=MAX(P2EFF,PMB**2)
22238           Q2EFF=MAX(Q2,P2EFF)
22239           TDIFF=LOG(Q2EFF/P2EFF)
22240           S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
22241      &    LOG(P2EFF/ALAMSQ(NFQ)))
22242         ENDIF
22243
22244 C...Evaluate flavour-dependent prefactor (charge^2 etc.).
22245         CHSQ=1D0/9D0
22246         IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
22247         FAC=AEM2PI*2D0*CHSQ*TDIFF
22248
22249 C...Evaluate parton distributions (normalized to unit momentum sum).
22250         IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
22251           XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
22252      &    (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
22253      &    1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
22254      &    X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
22255           XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
22256      &    X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
22257      &    ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
22258           XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
22259      &    X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
22260      &    ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
22261      &    (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
22262
22263 C...Threshold factors for c and b sea.
22264           SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
22265           XCHM=0D0
22266           IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22267             SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22268             XCHM=XSEA*(1D0-(SCH/SLL)**3)
22269           ENDIF
22270           XBOT=0D0
22271           IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
22272             SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
22273             XBOT=XSEA*(1D0-(SBT/SLL)**3)
22274           ENDIF
22275         ENDIF
22276
22277 C...Add contribution of each valence flavour.
22278         XPGA(0)=XPGA(0)+FAC*XGLU
22279         XPGA(1)=XPGA(1)+FAC*XSEA
22280         XPGA(2)=XPGA(2)+FAC*XSEA
22281         XPGA(3)=XPGA(3)+FAC*XSEA
22282         XPGA(4)=XPGA(4)+FAC*XCHM
22283         XPGA(5)=XPGA(5)+FAC*XBOT
22284         XPGA(KFL)=XPGA(KFL)+FAC*XVAL
22285         VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
22286   110 CONTINUE
22287       DO 120 KFL=1,5
22288         XPGA(-KFL)=XPGA(KFL)
22289         VXPGA(-KFL)=VXPGA(KFL)
22290   120 CONTINUE
22291
22292       RETURN
22293       END
22294
22295 C*********************************************************************
22296
22297 *$ CREATE PYGBEH.FOR
22298 *COPY PYGBEH
22299 C...PYGBEH
22300 C...Evaluates the Bethe-Heitler cross section for heavy flavour
22301 C...production.
22302 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22303
22304       SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
22305 C...Double precision and integer declarations.
22306       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22307       INTEGER PYK,PYCHGE,PYCOMP
22308
22309 C...Local data.
22310       DATA AEM2PI/0.0011614D0/
22311
22312 C...Reset output.
22313       XPBH=0D0
22314       SIGBH=0D0
22315
22316 C...Check kinematics limits.
22317       IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
22318       W2=Q2*(1D0-X)/X-P2
22319       BETA2=1D0-4D0*PM2/W2
22320       IF(BETA2.LT.1D-10) RETURN
22321       BETA=SQRT(BETA2)
22322       RMQ=4D0*PM2/Q2
22323
22324 C...Simple case: P2 = 0.
22325       IF(P2.LT.1D-4) THEN
22326         IF(BETA.LT.0.99D0) THEN
22327           XBL=LOG((1D0+BETA)/(1D0-BETA))
22328         ELSE
22329           XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
22330         ENDIF
22331         SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
22332      &  XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
22333
22334 C...Complicated case: P2 > 0, based on approximation of
22335 C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
22336       ELSE
22337         RPQ=1D0-4D0*X**2*P2/Q2
22338         IF(RPQ.GT.1D-10) THEN
22339           RPBE=SQRT(RPQ*BETA2)
22340           IF(RPBE.LT.0.99D0) THEN
22341             XBL=LOG((1D0+RPBE)/(1D0-RPBE))
22342             XBI=2D0*RPBE/(1D0-RPBE**2)
22343           ELSE
22344             RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
22345             XBL=LOG((1D0+RPBE)**2/RPBESN)
22346             XBI=2D0*RPBE/RPBESN
22347           ENDIF
22348           SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
22349      &    XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
22350      &    XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
22351         ENDIF
22352       ENDIF
22353
22354 C...Multiply by charge-squared etc. to get parton distribution.
22355       CHSQ=1D0/9D0
22356       IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
22357       XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
22358
22359       RETURN
22360       END
22361
22362 C*********************************************************************
22363
22364 *$ CREATE PYGDIR.FOR
22365 *COPY PYGDIR
22366 C...PYGDIR
22367 C...Evaluates the direct contribution, i.e. the C^gamma term,
22368 C...as needed in MSbar parametrizations.
22369 C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
22370
22371       SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
22372
22373 C...Double precision and integer declarations.
22374       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22375       INTEGER PYK,PYCHGE,PYCOMP
22376 C...Local array and data.
22377       DIMENSION XPGA(-6:6)
22378       DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
22379
22380 C...Reset output.
22381       DO 100 KFL=-6,6
22382         XPGA(KFL)=0D0
22383   100 CONTINUE
22384
22385 C...Evaluate common x-dependent expression.
22386       XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
22387       CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
22388
22389 C...d, u, s part by simple charge factor.
22390       XPGA(1)=(1D0/9D0)*CGAM
22391       XPGA(2)=(4D0/9D0)*CGAM
22392       XPGA(3)=(1D0/9D0)*CGAM
22393
22394 C...Also fill for antiquarks.
22395       DO 110 KF=1,5
22396         XPGA(-KF)=XPGA(KF)
22397   110 CONTINUE
22398
22399       RETURN
22400       END
22401
22402 C*********************************************************************
22403
22404 *$ CREATE PYPDPI.FOR
22405 *COPY PYPDPI
22406 C...PYPDPI
22407 C...Gives pi+ parton distribution according to two different
22408 C...parametrizations.
22409
22410       SUBROUTINE PYPDPI(X,Q2,XPPI)
22411
22412 C...Double precision and integer declarations.
22413       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22414       INTEGER PYK,PYCHGE,PYCOMP
22415 C...Commonblocks.
22416       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22417       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22418       COMMON/PYINT1/MINT(400),VINT(400)
22419       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
22420 C...Local arrays.
22421       DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
22422
22423 C...The following data lines are coefficients needed in the
22424 C...Owens pion parton distribution parametrizations, see below.
22425 C...Expansion coefficients for up and down valence quark distributions.
22426       DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
22427      &4.0000D-01,  7.0000D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
22428      &-6.2120D-02,  6.4780D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
22429      &-7.1090D-03,  1.3350D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
22430       DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
22431      &4.0000D-01,  6.2800D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
22432      &-5.9090D-02,  6.4360D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
22433      &-6.5240D-03,  1.4510D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
22434 C...Expansion coefficients for gluon distribution.
22435       DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
22436      &8.8800D-01,  0.0000D+00,  3.1100D+00,  6.0000D+00,  0.0000D+00,
22437      &-1.8020D+00, -1.5760D+00, -1.3170D-01,  2.8010D+00, -1.7280D+01,
22438      &1.8120D+00,  1.2000D+00,  5.0680D-01, -1.2160D+01,  2.0490D+01/
22439       DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
22440      &7.9400D-01,  0.0000D+00,  2.8900D+00,  6.0000D+00,  0.0000D+00,
22441      &-9.1440D-01, -1.2370D+00,  5.9660D-01, -3.6710D+00, -8.1910D+00,
22442      &5.9660D-01,  6.5820D-01, -2.5500D-01, -2.3040D+00,  7.7580D+00/
22443 C...Expansion coefficients for (up+down+strange) quark sea distribution.
22444       DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
22445      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
22446      &-2.4280D-01, -2.1200D-01,  8.6730D-01,  1.2660D+00,  2.3820D+00,
22447      &1.3860D-01,  3.6710D-03,  4.7470D-02, -2.2150D+00,  3.4820D-01/
22448       DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
22449      &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
22450      &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00,  5.6210D-01,
22451      &-1.7400D-01, -9.6230D-02,  1.5750D+00,  1.3780D+00, -2.7010D-01/
22452 C...Expansion coefficients for charm quark sea distribution.
22453       DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
22454      &0.0000D+00, -2.2120D-02,  2.8940D+00,  0.0000D+00,  0.0000D+00,
22455      &7.9280D-02, -3.7850D-01,  9.4330D+00,  5.2480D+00,  8.3880D+00,
22456      &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
22457       DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
22458      &0.0000D+00, -8.8200D-02,  1.9240D+00,  0.0000D+00,  0.0000D+00,
22459      &6.2290D-02, -2.8920D-01,  2.4240D-01, -4.4630D+00, -8.3670D-01,
22460      &-4.0990D-02, -1.0820D-01,  2.0360D+00,  5.2090D+00, -4.8400D-02/
22461
22462 C...Euler's beta function, requires ordinary Gamma function
22463       EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
22464
22465 C...Reset output array.
22466       DO 100 KFL=-6,6
22467         XPPI(KFL)=0D0
22468   100 CONTINUE
22469
22470       IF(MSTP(53).LE.2) THEN
22471 C...Pion parton distributions from Owens.
22472 C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
22473
22474 C...Determine set, Lambda and s expansion variable.
22475         NSET=MSTP(53)
22476         IF(NSET.EQ.1) ALAM=0.2D0
22477         IF(NSET.EQ.2) ALAM=0.4D0
22478         VINT(231)=4D0
22479         IF(MSTP(57).LE.0) THEN
22480           SD=0D0
22481         ELSE
22482           Q2IN=MIN(2D3,MAX(4D0,Q2))
22483           SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
22484         ENDIF
22485
22486 C...Calculate parton distributions.
22487         DO 120 KFL=1,4
22488           DO 110 IS=1,5
22489             TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
22490      &      COW(3,IS,KFL,NSET)*SD**2
22491   110     CONTINUE
22492           IF(KFL.EQ.1) THEN
22493             XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
22494           ELSE
22495             XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
22496      &      TS(5)*X**2)
22497           ENDIF
22498   120   CONTINUE
22499
22500 C...Put into output array.
22501         XPPI(0)=XQ(2)
22502         XPPI(1)=XQ(3)/6D0
22503         XPPI(2)=XQ(1)+XQ(3)/6D0
22504         XPPI(3)=XQ(3)/6D0
22505         XPPI(4)=XQ(4)
22506         XPPI(-1)=XQ(1)+XQ(3)/6D0
22507         XPPI(-2)=XQ(3)/6D0
22508         XPPI(-3)=XQ(3)/6D0
22509         XPPI(-4)=XQ(4)
22510
22511 C...Leading order pion parton distributions from Gluck, Reya and Vogt.
22512 C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
22513 C...10^-5 < x < 1.
22514       ELSE
22515
22516 C...Determine s expansion variable and some x expressions.
22517         VINT(231)=0.25D0
22518         IF(MSTP(57).LE.0) THEN
22519           SD=0D0
22520         ELSE
22521           Q2IN=MIN(1D8,MAX(0.25D0,Q2))
22522           SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
22523         ENDIF
22524         SD2=SD**2
22525         XL=-LOG(X)
22526         XS=SQRT(X)
22527
22528 C...Evaluate valence, gluon and sea distributions.
22529         XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
22530      &  (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
22531         XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
22532      &  SD-0.175D0*SD2)+
22533      &  (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
22534      &  SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
22535      &  XL)))*
22536      &  (1D0-X)**(0.390D0+1.053D0*SD)
22537         XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
22538      &  X)**3.359D0*
22539      &  EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
22540      &  XL))/
22541      &  XL**(2.538D0-0.763D0*SD)
22542         IF(SD.LE.0.888D0) THEN
22543           XFCHM=0D0
22544         ELSE
22545           XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
22546      &    0.771D0*SD)*
22547      &    EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
22548      &    XL))
22549         ENDIF
22550         IF(SD.LE.1.351D0) THEN
22551           XFBOT=0D0
22552         ELSE
22553           XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
22554      &    EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
22555      &    XL))
22556         ENDIF
22557
22558 C...Put into output array.
22559         XPPI(0)=XFGLU
22560         XPPI(1)=XFSEA
22561         XPPI(2)=XFSEA
22562         XPPI(3)=XFSEA
22563         XPPI(4)=XFCHM
22564         XPPI(5)=XFBOT
22565         DO 130 KFL=1,5
22566           XPPI(-KFL)=XPPI(KFL)
22567   130   CONTINUE
22568         XPPI(2)=XPPI(2)+XFVAL
22569         XPPI(-1)=XPPI(-1)+XFVAL
22570       ENDIF
22571
22572       RETURN
22573       END
22574
22575 C*********************************************************************
22576
22577 *$ CREATE PYPDPR.FOR
22578 *COPY PYPDPR
22579 C...PYPDPR
22580 C...Gives proton parton distributions according to a few different
22581 C...parametrizations.
22582
22583       SUBROUTINE PYPDPR(X,Q2,XPPR)
22584
22585 C...Double precision and integer declarations.
22586       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22587       INTEGER PYK,PYCHGE,PYCOMP
22588 C...Commonblocks.
22589       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22590       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22591       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22592       COMMON/PYINT1/MINT(400),VINT(400)
22593       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
22594 C...Arrays and data.
22595       DIMENSION XPPR(-6:6),Q2MIN(6)
22596       DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/
22597
22598 C...Reset output array.
22599       DO 100 KFL=-6,6
22600         XPPR(KFL)=0D0
22601   100 CONTINUE
22602
22603 C...Common preliminaries.
22604       NSET=MAX(1,MIN(6,MSTP(51)))
22605       VINT(231)=Q2MIN(NSET)
22606       IF(MSTP(57).EQ.0) THEN
22607         Q2L=Q2MIN(NSET)
22608       ELSE
22609         Q2L=MAX(Q2MIN(NSET),Q2)
22610       ENDIF
22611
22612       IF(NSET.GE.1.AND.NSET.LE.3) THEN
22613 C...Interface to the CTEQ 3 parton distributions.
22614         QRT=SQRT(MAX(1D0,Q2L))
22615
22616 C...Loop over flavours.
22617         DO 110 I=-6,6
22618           IF(I.LE.0) THEN
22619             XPPR(I)=PYCTEQ(NSET,I,X,QRT)
22620           ELSEIF(I.LE.2) THEN
22621             XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
22622           ELSE
22623             XPPR(I)=XPPR(-I)
22624           ENDIF
22625   110   CONTINUE
22626
22627       ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
22628 C...Interface to the GRV 94 distributions.
22629         IF(NSET.EQ.4) THEN
22630           CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22631         ELSEIF(NSET.EQ.5) THEN
22632           CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22633         ELSE
22634           CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22635         ENDIF
22636
22637 C...Put into output array.
22638         XPPR(0)=GL
22639         XPPR(-1)=0.5D0*(UDB+DEL)
22640         XPPR(-2)=0.5D0*(UDB-DEL)
22641         XPPR(-3)=SB
22642         XPPR(-4)=CHM
22643         XPPR(-5)=BOT
22644         XPPR(1)=DV+XPPR(-1)
22645         XPPR(2)=UV+XPPR(-2)
22646         XPPR(3)=SB
22647         XPPR(4)=CHM
22648         XPPR(5)=BOT
22649
22650       ENDIF
22651
22652       RETURN
22653       END
22654
22655 C*********************************************************************
22656
22657 *$ CREATE PYCTEQ.FOR
22658 *COPY PYCTEQ
22659 C...PYCTEQ
22660 C...Gives the CTEQ 3 parton distribution function sets in
22661 C...parametrized form, of October 24, 1994.
22662 C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
22663 C...J. Qiu, W.K. Tung and H. Weerts.
22664
22665       FUNCTION PYCTEQ (ISET, IPRT, X, Q)
22666
22667 C...Double precision declaration.
22668       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22669
22670 C...Data on Lambda values of fits, minimum Q and quark masses.
22671       DIMENSION ALM(3), QMS(4:6)
22672       DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
22673       DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
22674
22675 C....Check flavour thresholds. Set up QI for SB.
22676       IP = IABS(IPRT)
22677       IF(IP .GE. 4) THEN
22678         IF(Q .LE. QMS(IP)) THEN
22679           PYCTEQ = 0D0
22680           RETURN
22681         ENDIF
22682         QI = QMS(IP)
22683       ELSE
22684         QI = QMN
22685       ENDIF
22686
22687 C...Use "standard lambda" of parametrization program for expansion.
22688       ALAM = ALM (ISET)
22689       SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
22690       SB = LOG (SBL)
22691       SB2 = SB*SB
22692       SB3 = SB2*SB
22693
22694 C...Expansion for CTEQ3L.
22695       IF(ISET .EQ. 1) THEN
22696         IF(IPRT .EQ. 2) THEN
22697           A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
22698      &    0.3171D+00*SB3)
22699           A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
22700           A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
22701           A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
22702           A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
22703           A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
22704         ELSEIF(IPRT .EQ. 1) THEN
22705           A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
22706      &    0.7728D+00*SB3)
22707           A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
22708           A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
22709           A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
22710           A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
22711           A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
22712         ELSEIF(IPRT .EQ. 0) THEN
22713           A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
22714      &    0.5343D+00*SB3)
22715           A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
22716           A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
22717           A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
22718           A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
22719           A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
22720         ELSEIF(IPRT .EQ. -1) THEN
22721           A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
22722      &    0.2031D+01*SB3)
22723           A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
22724           A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
22725           A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
22726           A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
22727           A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
22728         ELSEIF(IPRT .EQ. -2) THEN
22729           A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
22730      &    0.9872D-01*SB3)
22731           A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
22732           A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
22733           A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
22734           A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
22735           A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
22736         ELSEIF(IPRT .EQ. -3) THEN
22737           A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
22738      &    0.8390D+00*SB3)
22739           A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
22740           A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
22741           A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
22742           A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
22743           A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
22744         ELSEIF(IPRT .EQ. -4) THEN
22745           A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
22746      &    0.1651D-01*SB2)
22747           A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
22748           A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
22749           A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
22750           A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
22751           A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
22752         ELSEIF(IPRT .EQ. -5) THEN
22753           A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
22754      &    0.3702D+01*SB2)
22755           A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
22756           A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
22757           A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
22758           A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
22759           A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
22760         ELSEIF(IPRT .EQ. -6) THEN
22761           A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
22762      &    0.6943D+00*SB2)
22763           A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
22764           A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
22765           A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
22766           A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
22767           A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
22768         ENDIF
22769
22770 C...Expansion for CTEQ3M.
22771       ELSEIF(ISET .EQ. 2) THEN
22772         IF(IPRT .EQ. 2) THEN
22773           A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
22774      &    0.2935D+00*SB3)
22775           A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
22776           A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
22777           A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
22778           A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
22779           A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
22780         ELSEIF(IPRT .EQ. 1) THEN
22781           A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
22782      &    0.4305D-01*SB3)
22783           A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
22784           A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
22785           A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
22786           A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
22787           A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
22788         ELSEIF(IPRT .EQ. 0) THEN
22789           A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
22790      &    0.1037D-01*SB3)
22791           A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
22792           A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
22793           A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
22794           A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
22795           A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
22796         ELSEIF(IPRT .EQ. -1) THEN
22797           A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
22798      &    0.1602D+01*SB3)
22799           A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
22800           A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
22801           A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
22802           A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
22803           A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
22804         ELSEIF(IPRT .EQ. -2) THEN
22805           A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
22806      &    0.2496D+00*SB3)
22807           A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
22808           A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
22809           A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
22810           A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
22811           A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
22812         ELSEIF(IPRT .EQ. -3) THEN
22813           A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
22814      &    0.1936D+01*SB3)
22815           A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
22816           A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
22817           A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
22818           A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
22819           A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
22820         ELSEIF(IPRT .EQ. -4) THEN
22821           A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
22822      &    0.5348D+00*SB2)
22823           A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
22824           A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
22825           A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
22826           A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
22827           A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
22828         ELSEIF(IPRT .EQ. -5) THEN
22829           A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
22830      &    0.1569D+01*SB2)
22831           A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
22832           A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
22833           A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
22834           A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
22835           A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
22836         ELSEIF(IPRT .EQ. -6) THEN
22837           A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
22838      &    0.8838D+01*SB2)
22839           A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
22840           A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
22841           A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
22842           A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
22843           A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
22844         ENDIF
22845
22846 C...Expansion for CTEQ3D.
22847       ELSEIF(ISET .EQ. 3) THEN
22848         IF(IPRT .EQ. 2) THEN
22849           A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
22850      &    0.2902D+00*SB3)
22851           A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
22852           A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
22853           A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
22854           A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
22855           A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
22856         ELSEIF(IPRT .EQ. 1) THEN
22857           A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
22858      &    0.7257D+00*SB3)
22859           A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
22860           A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
22861           A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
22862           A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
22863           A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
22864         ELSEIF(IPRT .EQ. 0) THEN
22865           A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
22866      &    0.2734D-04*SB3)
22867           A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
22868           A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
22869           A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
22870           A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
22871           A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
22872         ELSEIF(IPRT .EQ. -1) THEN
22873           A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
22874      &    0.1671D+01*SB3)
22875           A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
22876           A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
22877           A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
22878           A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
22879           A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
22880         ELSEIF(IPRT .EQ. -2) THEN
22881           A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
22882      &    0.2223D+00*SB3)
22883           A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
22884           A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
22885           A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
22886           A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
22887           A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
22888         ELSEIF(IPRT .EQ. -3) THEN
22889           A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
22890      &    0.1937D+01*SB3)
22891           A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
22892           A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
22893           A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
22894           A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
22895           A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
22896         ELSEIF(IPRT .EQ. -4) THEN
22897           A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
22898      &    0.5137D+00*SB2)
22899           A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
22900           A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
22901           A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
22902           A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
22903           A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
22904         ELSEIF(IPRT .EQ. -5) THEN
22905           A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
22906      &    0.2143D+01*SB2)
22907           A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
22908           A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
22909           A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
22910           A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
22911           A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
22912         ELSEIF(IPRT .EQ. -6) THEN
22913           A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
22914      &    0.9998D+01*SB2)
22915           A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
22916           A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
22917           A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
22918           A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
22919           A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
22920         ENDIF
22921       ENDIF
22922
22923 C...Calculation of x * f(x, Q).
22924       PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
22925      &   *(LOG(1D0+1D0/X))**A5 )
22926
22927       RETURN
22928       END
22929
22930 C*********************************************************************
22931
22932 *$ CREATE PYGRVL.FOR
22933 *COPY PYGRVL
22934 C...PYGRVL
22935 C...Gives the GRV 94 L (leading order) parton distribution function set
22936 C...in parametrized form.
22937 C...Authors: M. Glueck, E. Reya and A. Vogt.
22938
22939       SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
22940
22941 C...Double precision declaration.
22942       IMPLICIT DOUBLE PRECISION (A - Z)
22943
22944 C...Common expressions.
22945       MU2  = 0.23D0
22946       LAM2 = 0.2322D0 * 0.2322D0
22947       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
22948       DS = SQRT (S)
22949       S2 = S * S
22950       S3 = S2 * S
22951
22952 C...uv :
22953       NU  =  2.284D0 + 0.802D0 * S + 0.055D0 * S2
22954       AKU =  0.590D0 - 0.024D0 * S
22955       BKU =  0.131D0 + 0.063D0 * S
22956       AU  = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
22957       BU  =  0.213D0 + 2.669D0 * S - 0.728D0 * S2
22958       CU  =  8.854D0 - 9.135D0 * S + 1.979D0 * S2
22959       DU  =  2.997D0 + 0.753D0 * S - 0.076D0 * S2
22960       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
22961
22962 C...dv :
22963       ND  =  0.371D0 + 0.083D0 * S + 0.039D0 * S2
22964       AKD =  0.376D0
22965       BKD =  0.486D0 + 0.062D0 * S
22966       AD  = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
22967       BD  =  12.41D0 - 10.52D0 * S + 2.267D0 * S2
22968       CD  =  6.373D0 - 6.208D0 * S + 1.418D0 * S2
22969       DD  =  3.691D0 + 0.799D0 * S - 0.071D0 * S2
22970       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
22971
22972 C...del :
22973       NE  =  0.082D0 + 0.014D0 * S + 0.008D0 * S2
22974       AKE =  0.409D0 - 0.005D0 * S
22975       BKE =  0.799D0 + 0.071D0 * S
22976       AE  = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
22977       BE  =  90.31D0 - 74.15D0 * S + 7.645D0 * S2
22978       CE  =  0.0D0
22979       DE  =  7.486D0 + 1.217D0 * S - 0.159D0 * S2
22980       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
22981
22982 C...udb :
22983       ALX =  1.451D0
22984       BEX =  0.271D0
22985       AKX =  0.410D0 - 0.232D0 * S
22986       BKX =  0.534D0 - 0.457D0 * S
22987       AGX =  0.890D0 - 0.140D0 * S
22988       BGX = -0.981D0
22989       CX  =  0.320D0 + 0.683D0 * S
22990       DX  =  4.752D0 + 1.164D0 * S + 0.286D0 * S2
22991       EX  =  4.119D0 + 1.713D0 * S
22992       ESX =  0.682D0 + 2.978D0 * S
22993       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
22994      & DX, EX, ESX)
22995
22996 C...sb :
22997       STS =  0D0
22998       ALS =  0.914D0
22999       BES =  0.577D0
23000       AKS =  1.798D0 - 0.596D0 * S
23001       AS  = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
23002       BS  =  18.92D0 - 16.73D0 * DS + 5.168D0 * S
23003       DST =  6.379D0 - 0.350D0 * S  + 0.142D0 * S2
23004       EST =  3.981D0 + 1.638D0 * S
23005       ESS =  6.402D0
23006       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23007
23008 C...cb :
23009       STC =  0.888D0
23010       ALC =  1.01D0
23011       BEC =  0.37D0
23012       AKC =  0D0
23013       AC  =  0D0
23014       BC  =  4.24D0  - 0.804D0 * S
23015       DCT =  3.46D0  - 1.076D0 * S
23016       ECT =  4.61D0  + 1.49D0  * S
23017       ESC =  2.555D0 + 1.961D0 * S
23018       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23019
23020 C...bb :
23021       STB =  1.351D0
23022       ALB =  1.00D0
23023       BEB =  0.51D0
23024       AKB =  0D0
23025       AB  =  0D0
23026       BB  =  1.848D0
23027       DBT =  2.929D0 + 1.396D0 * S
23028       EBT =  4.71D0  + 1.514D0 * S
23029       ESB =  4.02D0  + 1.239D0 * S
23030       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23031
23032 C...gl :
23033       ALG =  0.524D0
23034       BEG =  1.088D0
23035       AKG =  1.742D0 - 0.930D0 * S
23036       BKG =                         - 0.399D0 * S2
23037       AG  =  7.486D0 - 2.185D0 * S
23038       BG  =  16.69D0 - 22.74D0 * S  + 5.779D0 * S2
23039       CG  = -25.59D0 + 29.71D0 * S  - 7.296D0 * S2
23040       DG  =  2.792D0 + 2.215D0 * S  + 0.422D0 * S2 - 0.104D0 * S3
23041       EG  =  0.807D0 + 2.005D0 * S
23042       ESG =  3.841D0 + 0.316D0 * S
23043       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
23044      & DG, EG, ESG)
23045
23046       RETURN
23047       END
23048
23049 C*********************************************************************
23050
23051 *$ CREATE PYGRVM.FOR
23052 *COPY PYGRVM
23053 C...PYGRVM
23054 C...Gives the GRV 94 M (MSbar) parton distribution function set
23055 C...in parametrized form.
23056 C...Authors: M. Glueck, E. Reya and A. Vogt.
23057
23058       SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23059
23060 C...Double precision declaration.
23061       IMPLICIT DOUBLE PRECISION (A - Z)
23062
23063 C...Common expressions.
23064       MU2  = 0.34D0
23065       LAM2 = 0.248D0 * 0.248D0
23066       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23067       DS = SQRT (S)
23068       S2 = S * S
23069       S3 = S2 * S
23070
23071 C...uv :
23072       NU  =  1.304D0 + 0.863D0 * S
23073       AKU =  0.558D0 - 0.020D0 * S
23074       BKU =          0.183D0 * S
23075       AU  = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
23076       BU  =  6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
23077       CU  =  7.771D0 - 10.09D0 * S + 2.630D0 * S2
23078       DU  =  3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
23079       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23080
23081 C...dv :
23082       ND  =  0.102D0 - 0.017D0 * S + 0.005D0 * S2
23083       AKD =  0.270D0 - 0.019D0 * S
23084       BKD =  0.260D0
23085       AD  =  2.393D0 + 6.228D0 * S - 0.881D0 * S2
23086       BD  =  46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
23087       CD  =  17.83D0 - 53.47D0 * S + 21.24D0 * S2
23088       DD  =  4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
23089       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23090
23091 C...del :
23092       NE  =  0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
23093       AKE =  0.409D0 - 0.007D0 * S
23094       BKE =  0.782D0 + 0.082D0 * S
23095       AE  = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
23096       BE  =  90.20D0 - 74.97D0 * S + 4.526D0 * S2
23097       CE  =  0.0D0
23098       DE  =  8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
23099       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23100
23101 C...udb :
23102       ALX =  0.877D0
23103       BEX =  0.561D0
23104       AKX =  0.275D0
23105       BKX =  0.0D0
23106       AGX =  0.997D0
23107       BGX =  3.210D0 - 1.866D0 * S
23108       CX  =  7.300D0
23109       DX  =  9.010D0 + 0.896D0 * DS + 0.222D0 * S2
23110       EX  =  3.077D0 + 1.446D0 * S
23111       ESX =  3.173D0 - 2.445D0 * DS + 2.207D0 * S
23112       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23113      & DX, EX, ESX)
23114
23115 C...sb :
23116       STS =  0D0
23117       ALS =  0.756D0
23118       BES =  0.216D0
23119       AKS =  1.690D0 + 0.650D0 * DS - 0.922D0 * S
23120       AS  = -4.329D0 + 1.131D0 * S
23121       BS  =  9.568D0 - 1.744D0 * S
23122       DST =  9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
23123       EST =  3.031D0 + 1.639D0 * S
23124       ESS =  5.837D0 + 0.815D0 * S
23125       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23126
23127 C...cb :
23128       STC =  0.820D0
23129       ALC =  0.98D0
23130       BEC =  0D0
23131       AKC = -0.625D0 - 0.523D0 * S
23132       AC  =  0D0
23133       BC  =  1.896D0 + 1.616D0 * S
23134       DCT =  4.12D0  + 0.683D0 * S
23135       ECT =  4.36D0  + 1.328D0 * S
23136       ESC =  0.677D0 + 0.679D0 * S
23137       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23138
23139 C...bb :
23140       STB =  1.297D0
23141       ALB =  0.99D0
23142       BEB =  0D0
23143       AKB =          - 0.193D0 * S
23144       AB  =  0D0
23145       BB  =  0D0
23146       DBT =  3.447D0 + 0.927D0 * S
23147       EBT =  4.68D0  + 1.259D0 * S
23148       ESB =  1.892D0 + 2.199D0 * S
23149       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23150
23151 C...gl :
23152        ALG =  1.014D0
23153        BEG =  1.738D0
23154        AKG =  1.724D0 + 0.157D0 * S
23155        BKG =  0.800D0 + 1.016D0 * S
23156        AG  =  7.517D0 - 2.547D0 * S
23157        BG  =  34.09D0 - 52.21D0 * DS + 17.47D0 * S
23158        CG  =  4.039D0 + 1.491D0 * S
23159        DG  =  3.404D0 + 0.830D0 * S
23160        EG  = -1.112D0 + 3.438D0 * S  - 0.302D0 * S2
23161        ESG =  3.256D0 - 0.436D0 * S
23162        GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23163
23164        RETURN
23165        END
23166
23167 C*********************************************************************
23168
23169 *$ CREATE PYGRVD.FOR
23170 *COPY PYGRVD
23171 C...PYGRVD
23172 C...Gives the GRV 94 D (DIS) parton distribution function set
23173 C...in parametrized form.
23174 C...Authors: M. Glueck, E. Reya and A. Vogt.
23175
23176       SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
23177
23178 C...Double precision declaration.
23179       IMPLICIT DOUBLE PRECISION (A - Z)
23180
23181 C...Common expressions.
23182       MU2  = 0.34D0
23183       LAM2 = 0.248D0 * 0.248D0
23184       S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
23185       DS = SQRT (S)
23186       S2 = S * S
23187       S3 = S2 * S
23188
23189 C...uv :
23190       NU  =  2.484D0 + 0.116D0 * S + 0.093D0 * S2
23191       AKU =  0.563D0 - 0.025D0 * S
23192       BKU =  0.054D0 + 0.154D0 * S
23193       AU  = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
23194       BU  = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
23195       CU  =  11.52D0 - 12.99D0 * S + 3.161D0 * S2
23196       DU  =  2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
23197       UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
23198
23199 C...dv :
23200       ND  =  0.156D0 - 0.017D0 * S
23201       AKD =  0.299D0 - 0.022D0 * S
23202       BKD =  0.259D0 - 0.015D0 * S
23203       AD  =  3.445D0 + 1.278D0 * S + 0.326D0 * S2
23204       BD  = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
23205       CD  =  55.45D0 - 69.92D0 * S + 20.78D0 * S2
23206       DD  =  3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
23207       DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
23208
23209 C...del :
23210       NE  =  0.099D0 + 0.019D0 * S + 0.002D0 * S2
23211       AKE =  0.419D0 - 0.013D0 * S
23212       BKE =  1.064D0 - 0.038D0 * S
23213       AE  = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
23214       BE  =  28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
23215       CE  =  84.57D0 - 108.8D0 * S + 31.52D0 * S2
23216       DE  =  7.469D0 + 2.480D0 * S - 0.866D0 * S2
23217       DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
23218
23219 C...udb :
23220       ALX =  1.215D0
23221       BEX =  0.466D0
23222       AKX =  0.326D0 + 0.150D0 * S
23223       BKX =  0.956D0 + 0.405D0 * S
23224       AGX =  0.272D0
23225       BGX =  3.794D0 - 2.359D0 * DS
23226       CX  =  2.014D0
23227       DX  =  7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
23228       EX  =  3.049D0 + 1.597D0 * S
23229       ESX =  4.396D0 - 4.594D0 * DS + 3.268D0 * S
23230       UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
23231      & DX, EX, ESX)
23232
23233 C...sb :
23234       STS =  0D0
23235       ALS =  0.175D0
23236       BES =  0.344D0
23237       AKS =  1.415D0 - 0.641D0 * DS
23238       AS  =  0.580D0 - 9.763D0 * DS + 6.795D0 * S  - 0.558D0 * S2
23239       BS  =  5.617D0 + 5.709D0 * DS - 3.972D0 * S
23240       DST =  13.78D0 - 9.581D0 * S  + 5.370D0 * S2 - 0.996D0 * S3
23241       EST =  4.546D0 + 0.372D0 * S2
23242       ESS =  5.053D0 - 1.070D0 * S  + 0.805D0 * S2
23243       SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
23244
23245 C...cb :
23246       STC =  0.820D0
23247       ALC =  0.98D0
23248       BEC =  0D0
23249       AKC = -0.625D0 - 0.523D0 * S
23250       AC  =  0D0
23251       BC  =  1.896D0 + 1.616D0 * S
23252       DCT =  4.12D0  + 0.683D0 * S
23253       ECT =  4.36D0  + 1.328D0 * S
23254       ESC =  0.677D0 + 0.679D0 * S
23255       CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
23256
23257 C...bb :
23258       STB =  1.297D0
23259       ALB =  0.99D0
23260       BEB =  0D0
23261       AKB =          - 0.193D0 * S
23262       AB  =  0D0
23263       BB  =  0D0
23264       DBT =  3.447D0 + 0.927D0 * S
23265       EBT =  4.68D0  + 1.259D0 * S
23266       ESB =  1.892D0 + 2.199D0 * S
23267       BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
23268
23269 C...gl :
23270       ALG =  1.258D0
23271       BEG =  1.846D0
23272       AKG =  2.423D0
23273       BKG =  2.427D0 + 1.311D0 * S  - 0.153D0 * S2
23274       AG  =  25.09D0 - 7.935D0 * S
23275       BG  = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
23276       CG  =  590.3D0 - 173.8D0 * S
23277       DG  =  5.196D0 + 1.857D0 * S
23278       EG  = -1.648D0 + 3.988D0 * S  - 0.432D0 * S2
23279       ESG =  3.232D0 - 0.542D0 * S
23280       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
23281
23282       RETURN
23283       END
23284
23285 C*********************************************************************
23286
23287 *$ CREATE PYGRVV.FOR
23288 *COPY PYGRVV
23289 C...PYGRVV
23290 C...Auxiliary for the GRV 94 parton distribution functions
23291 C...for u and d valence and d-u sea.
23292 C...Authors: M. Glueck, E. Reya and A. Vogt.
23293
23294       FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
23295
23296 C...Double precision declaration.
23297       IMPLICIT DOUBLE PRECISION (A - Z)
23298
23299 C...Evaluation.
23300       DX = SQRT (X)
23301       PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
23302      & (1D0- X)**D
23303
23304       RETURN
23305       END
23306
23307 C*********************************************************************
23308
23309 *$ CREATE PYGRVW.FOR
23310 *COPY PYGRVW
23311 C...PYGRVW
23312 C...Auxiliary for the GRV 94 parton distribution functions
23313 C...for d+u sea and gluon.
23314 C...Authors: M. Glueck, E. Reya and A. Vogt.
23315
23316       FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
23317
23318 C...Double precision declaration.
23319       IMPLICIT DOUBLE PRECISION (A - Z)
23320
23321 C...Evaluation.
23322       LX = LOG (1D0/X)
23323       PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
23324      &     * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
23325
23326       RETURN
23327       END
23328
23329 C*********************************************************************
23330
23331 *$ CREATE PYGRVS.FOR
23332 *COPY PYGRVS
23333 C...PYGRVS
23334 C...Auxiliary for the GRV 94 parton distribution functions
23335 C...for s, c and b sea.
23336 C...Authors: M. Glueck, E. Reya and A. Vogt.
23337
23338       FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
23339
23340 C...Double precision declaration.
23341       IMPLICIT DOUBLE PRECISION (A - Z)
23342
23343 C...Evaluation.
23344       IF(S.LE.STH) THEN
23345         PYGRVS = 0D0
23346       ELSE
23347         DX = SQRT (X)
23348         LX = LOG (1D0/X)
23349         PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
23350      &     (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
23351       ENDIF
23352
23353       RETURN
23354       END
23355
23356 C*********************************************************************
23357
23358 *$ CREATE PYHFTH.FOR
23359 *COPY PYHFTH
23360 C...PYHFTH
23361 C...Gives threshold attractive/repulsive factor for heavy flavour
23362 C...production.
23363
23364       FUNCTION PYHFTH(SH,SQM,FRATT)
23365
23366 C...Double precision and integer declarations.
23367       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23368       INTEGER PYK,PYCHGE,PYCOMP
23369 C...Commonblocks.
23370       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23371       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23372       COMMON/PYINT1/MINT(400),VINT(400)
23373       SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23374
23375 C...Value for alpha_strong.
23376       IF(MSTP(35).LE.1) THEN
23377         ALSSG=PARP(35)
23378       ELSE
23379         MST115=MSTU(115)
23380         MSTU(115)=MSTP(36)
23381         Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
23382      &  PARP(36)**2)))
23383         ALSSG=PYALPS(Q2BN)
23384         MSTU(115)=MST115
23385       ENDIF
23386
23387 C...Evaluate attractive and repulsive factors.
23388       XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23389       FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
23390       XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
23391       FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
23392       PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
23393       VINT(138)=PYHFTH
23394
23395       RETURN
23396       END
23397
23398 C*********************************************************************
23399
23400 *$ CREATE PYSPLI.FOR
23401 *COPY PYSPLI
23402 C...PYSPLI
23403 C...Splits a hadron remnant into two (partons or hadron + parton)
23404 C...in case it is more complicated than just a quark or a diquark.
23405
23406       SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
23407
23408 C...Double precision and integer declarations.
23409       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23410       INTEGER PYK,PYCHGE,PYCOMP
23411 C...Commonblocks.
23412       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23413       COMMON/PYINT1/MINT(400),VINT(400)
23414       SAVE /PYPARS/,/PYINT1/
23415 C...Local array.
23416       DIMENSION KFL(3)
23417
23418 C...Preliminaries. Parton composition.
23419       KFA=IABS(KF)
23420       KFS=ISIGN(1,KF)
23421       KFL(1)=MOD(KFA/1000,10)
23422       KFL(2)=MOD(KFA/100,10)
23423       KFL(3)=MOD(KFA/10,10)
23424       IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
23425         KFL(2)=INT(1.5D0+PYR(0))
23426         IF(MINT(105).EQ.333) KFL(2)=3
23427         IF(MINT(105).EQ.443) KFL(2)=4
23428         KFL(3)=KFL(2)
23429       ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
23430         KFL(2)=2
23431         KFL(3)=2
23432       ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
23433         KFL(2)=1
23434         KFL(3)=1
23435       ENDIF
23436       IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
23437         KFLR=KFLIN*KFS
23438       ELSE
23439         KFLR=KFLIN
23440       ENDIF
23441       KFLCH=0
23442
23443 C...Subdivide lepton.
23444       IF(KFA.GE.11.AND.KFA.LE.18) THEN
23445         IF(KFLR.EQ.KFA) THEN
23446           KFLSP=KFS*22
23447         ELSEIF(KFLR.EQ.22) THEN
23448           KFLSP=KFA
23449         ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
23450           KFLSP=KFA+1
23451         ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
23452           KFLSP=KFA-1
23453         ELSEIF(KFLR.EQ.21) THEN
23454           KFLSP=KFA
23455           KFLCH=KFS*21
23456         ELSE
23457           KFLSP=KFA
23458           KFLCH=-KFLR
23459         ENDIF
23460
23461 C...Subdivide photon.
23462       ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
23463         IF(KFLR.NE.21) THEN
23464           KFLSP=-KFLR
23465         ELSE
23466           RAGR=0.75D0*PYR(0)
23467           KFLSP=1
23468           IF(RAGR.GT.0.125D0) KFLSP=2
23469           IF(RAGR.GT.0.625D0) KFLSP=3
23470           IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
23471           KFLCH=-KFLSP
23472         ENDIF
23473
23474 C...Subdivide Reggeon or Pomeron.
23475       ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN
23476         IF(KFLIN.EQ.21) THEN
23477           KFLSP=KFS*21
23478         ELSE
23479           KFLSP=-KFLIN
23480         ENDIF
23481
23482 C...Subdivide meson.
23483       ELSEIF(KFL(1).EQ.0) THEN
23484         KFL(2)=KFL(2)*(-1)**KFL(2)
23485         KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
23486         IF(KFLR.EQ.KFL(2)) THEN
23487           KFLSP=KFL(3)
23488         ELSEIF(KFLR.EQ.KFL(3)) THEN
23489           KFLSP=KFL(2)
23490         ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
23491           KFLSP=KFL(2)
23492           KFLCH=KFL(3)
23493         ELSEIF(KFLR.EQ.21) THEN
23494           KFLSP=KFL(3)
23495           KFLCH=KFL(2)
23496         ELSEIF(KFLR*KFL(2).GT.0) THEN
23497           CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
23498           KFLSP=KFL(3)
23499         ELSE
23500           CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
23501           KFLSP=KFL(2)
23502         ENDIF
23503
23504 C...Subdivide baryon.
23505       ELSE
23506         NAGR=0
23507         DO 100 J=1,3
23508           IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
23509   100   CONTINUE
23510         IF(NAGR.GE.1) THEN
23511           RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
23512           IAGR=0
23513           DO 110 J=1,3
23514             IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
23515             IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
23516   110     CONTINUE
23517         ELSE
23518           IAGR=1.00001D0+2.99998D0*PYR(0)
23519         ENDIF
23520         ID1=1
23521         IF(IAGR.EQ.1) ID1=2
23522         IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
23523         ID2=6-IAGR-ID1
23524         KSP=3
23525         IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
23526           IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
23527         ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
23528           IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
23529         ELSEIF(MOD(KFA,10).EQ.2) THEN
23530           IF(IAGR.EQ.1) KSP=1
23531           IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
23532         ENDIF
23533         KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
23534         IF(KFLR.EQ.21) THEN
23535           KFLCH=KFL(IAGR)
23536         ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
23537           CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
23538         ELSEIF(NAGR.EQ.0) THEN
23539           CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH)
23540           KFLSP=KFL(IAGR)
23541         ENDIF
23542       ENDIF
23543
23544 C...Add on correct sign for result.
23545       KFLCH=KFLCH*KFS
23546       KFLSP=KFLSP*KFS
23547
23548       RETURN
23549       END
23550
23551 C*********************************************************************
23552
23553 *$ CREATE PYGAMM.FOR
23554 *COPY PYGAMM
23555 C...PYGAMM
23556 C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
23557 C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
23558 C...(Dover, 1965) 6.1.36.
23559
23560       FUNCTION PYGAMM(X)
23561
23562 C...Double precision and integer declarations.
23563       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23564       INTEGER PYK,PYCHGE,PYCOMP
23565 C...Local array and data.
23566       DIMENSION B(8)
23567       DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
23568      &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
23569
23570       NX=INT(X)
23571       DX=X-NX
23572
23573       PYGAMM=1D0
23574       DXP=1D0
23575       DO 100 I=1,8
23576         DXP=DXP*DX
23577         PYGAMM=PYGAMM+B(I)*DXP
23578   100 CONTINUE
23579       IF(X.LT.1D0) THEN
23580         PYGAMM=PYGAMM/X
23581       ELSE
23582         DO 110 IX=1,NX-1
23583           PYGAMM=(X-IX)*PYGAMM
23584   110   CONTINUE
23585       ENDIF
23586
23587       RETURN
23588       END
23589
23590 C***********************************************************************
23591
23592 *$ CREATE PYWAUX.FOR
23593 *COPY PYWAUX
23594 C...PYWAUX
23595 C...Calculates real and imaginary parts of the auxiliary functions W1
23596 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
23597 C...der Bij, Nucl. Phys. B297 (1988) 221.
23598
23599       SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
23600
23601 C...Double precision and integer declarations.
23602       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23603       INTEGER PYK,PYCHGE,PYCOMP
23604 C...Commonblocks.
23605       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23606       SAVE /PYDAT1/
23607
23608       ASINH(X)=LOG(X+SQRT(X**2+1D0))
23609       ACOSH(X)=LOG(X+SQRT(X**2-1D0))
23610
23611       IF(EPS.LT.0D0) THEN
23612         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
23613         IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
23614         WIM=0D0
23615       ELSEIF(EPS.LT.1D0) THEN
23616         IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
23617         IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
23618         IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
23619         IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
23620       ELSE
23621         IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
23622         IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
23623         WIM=0D0
23624       ENDIF
23625
23626       RETURN
23627       END
23628
23629 C***********************************************************************
23630
23631 *$ CREATE PYI3AU.FOR
23632 *COPY PYI3AU
23633 C...PYI3AU
23634 C...Calculates real and imaginary parts of the auxiliary function I3;
23635 C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
23636 C...Nucl. Phys. B297 (1988) 221.
23637
23638       SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
23639
23640 C...Double precision and integer declarations.
23641       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23642       INTEGER PYK,PYCHGE,PYCOMP
23643 C...Commonblocks.
23644       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23645       SAVE /PYDAT1/
23646
23647       BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
23648       IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
23649
23650       IF(EPS.LT.0D0) THEN
23651         IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23652           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23653      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23654      &    PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
23655      &    PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
23656      &    LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
23657      &    LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
23658      &    LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
23659      &    EPS))
23660         ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23661           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23662      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23663      &    PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
23664      &    PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
23665      &    0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
23666      &    LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
23667      &    LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
23668         ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23669           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23670      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23671      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
23672      &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
23673      &    0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
23674      &    LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
23675      &    LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
23676         ELSE
23677           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23678      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
23679      &    PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
23680      &    LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
23681      &    LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
23682         ENDIF
23683         F3IM=0D0
23684       ELSEIF(EPS.LT.1D0) THEN
23685         IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23686           F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
23687      &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
23688      &    PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
23689      &    PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
23690      &    (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23691      &    (0.25D0*(RAT+1D0)*EPS))
23692           F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
23693      &    (0.25D0*(RAT+1D0)*EPS))
23694         ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN
23695           F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
23696      &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
23697      &    PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
23698      &    PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
23699      &    LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
23700      &    LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23701           F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
23702         ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN
23703           F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
23704      &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
23705      &    PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
23706      &    PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
23707      &    LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
23708      &    (1D0+0.25D0*RAT*EPS-GA))
23709           F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
23710      &    (1D0+0.25D0*RAT*EPS-GA))
23711         ELSE
23712           F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
23713      &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
23714      &    PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
23715      &    LOG((GA+BE-1D0)/(BE-GA))
23716           F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
23717         ENDIF
23718       ELSE
23719         RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
23720         RCTHE=RSQ*(1D0-2D0*BE/EPS)
23721         RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
23722         RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
23723         RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
23724         R=SQRT(RSQ)
23725         THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
23726         PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
23727         F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
23728      &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
23729      &  (PHI-THE)*(PHI+THE-PARU(1))
23730         F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
23731      &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
23732       ENDIF
23733
23734       Y3RE=2D0/(2D0*BE-1D0)*F3RE
23735       Y3IM=2D0/(2D0*BE-1D0)*F3IM
23736
23737       RETURN
23738       END
23739
23740 C***********************************************************************
23741
23742 *$ CREATE PYSPEN.FOR
23743 *COPY PYSPEN
23744 C...PYSPEN
23745 C...Calculates real and imaginary part of Spence function; see
23746 C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
23747
23748       FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
23749
23750 C...Double precision and integer declarations.
23751       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23752       INTEGER PYK,PYCHGE,PYCOMP
23753 C...Commonblocks.
23754       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23755       SAVE /PYDAT1/
23756 C...Local array and data.
23757       DIMENSION B(0:14)
23758       DATA B/
23759      &1.000000D+00,        -5.000000D-01,         1.666667D-01,
23760      &0.000000D+00,        -3.333333D-02,         0.000000D+00,
23761      &2.380952D-02,         0.000000D+00,        -3.333333D-02,
23762      &0.000000D+00,         7.575757D-02,         0.000000D+00,
23763      &-2.531135D-01,         0.000000D+00,         1.166667D+00/
23764
23765       XRE=XREIN
23766       XIM=XIMIN
23767       IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN
23768         IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
23769         IF(IREIM.EQ.2) PYSPEN=0D0
23770         RETURN
23771       ENDIF
23772
23773       XMOD=SQRT(XRE**2+XIM**2)
23774       IF(XMOD.LT.1.D-6) THEN
23775         IF(IREIM.EQ.1) PYSPEN=0D0
23776         IF(IREIM.EQ.2) PYSPEN=0D0
23777         RETURN
23778       ENDIF
23779
23780       XARG=SIGN(ACOS(XRE/XMOD),XIM)
23781       SP0RE=0D0
23782       SP0IM=0D0
23783       SGN=1D0
23784       IF(XMOD.GT.1D0) THEN
23785         ALGXRE=LOG(XMOD)
23786         ALGXIM=XARG-SIGN(PARU(1),XARG)
23787         SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
23788         SP0IM=-ALGXRE*ALGXIM
23789         SGN=-1D0
23790         XMOD=1D0/XMOD
23791         XARG=-XARG
23792         XRE=XMOD*COS(XARG)
23793         XIM=XMOD*SIN(XARG)
23794       ENDIF
23795       IF(XRE.GT.0.5D0) THEN
23796         ALGXRE=LOG(XMOD)
23797         ALGXIM=XARG
23798         XRE=1D0-XRE
23799         XIM=-XIM
23800         XMOD=SQRT(XRE**2+XIM**2)
23801         XARG=SIGN(ACOS(XRE/XMOD),XIM)
23802         ALGYRE=LOG(XMOD)
23803         ALGYIM=XARG
23804         SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
23805         SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
23806         SGN=-SGN
23807       ENDIF
23808
23809       XRE=1D0-XRE
23810       XIM=-XIM
23811       XMOD=SQRT(XRE**2+XIM**2)
23812       XARG=SIGN(ACOS(XRE/XMOD),XIM)
23813       ZRE=-LOG(XMOD)
23814       ZIM=-XARG
23815
23816       SPRE=0D0
23817       SPIM=0D0
23818       SAVERE=1D0
23819       SAVEIM=0D0
23820       DO 100 I=0,14
23821         IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
23822         TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
23823         TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
23824         SAVERE=TERMRE
23825         SAVEIM=TERMIM
23826         SPRE=SPRE+B(I)*TERMRE
23827         SPIM=SPIM+B(I)*TERMIM
23828   100 CONTINUE
23829
23830   110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
23831       IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
23832
23833       RETURN
23834       END
23835
23836 C***********************************************************************
23837
23838 *$ CREATE PYQQBH.FOR
23839 *COPY PYQQBH
23840 C...PYQQBH
23841 C...Calculates the matrix element for the processes
23842 C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
23843 C...REDUCE output and part of the rest courtesy Z. Kunszt, see
23844 C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
23845
23846       SUBROUTINE PYQQBH(WTQQBH)
23847
23848 C...Double precision and integer declarations.
23849       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23850       INTEGER PYK,PYCHGE,PYCOMP
23851 C...Commonblocks.
23852       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23853       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23854       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23855       COMMON/PYINT1/MINT(400),VINT(400)
23856       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23857       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
23858 C...Local arrays and function.
23859       DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
23860       DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
23861      &PP(I,3)*PP(J,3)
23862
23863 C...Mass parameters.
23864       WTQQBH=0D0
23865       ISUB=MINT(1)
23866       SHPR=SQRT(VINT(26))*VINT(1)
23867       PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
23868       PH=SQRT(VINT(21))*VINT(1)
23869       SPQ=PQ**2
23870       SPH=PH**2
23871
23872 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
23873       DO 100 I=1,2
23874         PT=SQRT(MAX(0D0,VINT(197+5*I)))
23875         PP(I,1)=PT*COS(VINT(198+5*I))
23876         PP(I,2)=PT*SIN(VINT(198+5*I))
23877   100 CONTINUE
23878       PP(3,1)=-PP(1,1)-PP(2,1)
23879       PP(3,2)=-PP(1,2)-PP(2,2)
23880       PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
23881       PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
23882       PMS3=SPH+PP(3,1)**2+PP(3,2)**2
23883       PMT3=SQRT(PMS3)
23884       PP(3,3)=PMT3*SINH(VINT(211))
23885       PP(3,4)=PMT3*COSH(VINT(211))
23886       PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
23887       PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
23888      &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
23889       PP(2,3)=-PP(1,3)-PP(3,3)
23890       PP(1,4)=SQRT(PMS1+PP(1,3)**2)
23891       PP(2,4)=SQRT(PMS2+PP(2,3)**2)
23892
23893 C...Set up incoming kinematics and derived momentum combinations.
23894       DO 110 I=4,5
23895         PP(I,1)=0D0
23896         PP(I,2)=0D0
23897         PP(I,3)=-0.5D0*SHPR*(-1)**I
23898         PP(I,4)=-0.5D0*SHPR
23899   110 CONTINUE
23900       DO 120 J=1,4
23901         PP(6,J)=PP(1,J)+PP(2,J)
23902         PP(7,J)=PP(1,J)+PP(3,J)
23903         PP(8,J)=PP(1,J)+PP(4,J)
23904         PP(9,J)=PP(1,J)+PP(5,J)
23905         PP(10,J)=-PP(2,J)-PP(3,J)
23906         PP(11,J)=-PP(2,J)-PP(4,J)
23907         PP(12,J)=-PP(2,J)-PP(5,J)
23908         PP(13,J)=-PP(4,J)-PP(5,J)
23909   120 CONTINUE
23910
23911 C...Derived kinematics invariants.
23912       X1=DOT(1,2)
23913       X2=DOT(1,3)
23914       X3=DOT(1,4)
23915       X4=DOT(1,5)
23916       X5=DOT(2,3)
23917       X6=DOT(2,4)
23918       X7=DOT(2,5)
23919       X8=DOT(3,4)
23920       X9=DOT(3,5)
23921       X10=DOT(4,5)
23922
23923 C...Propagators.
23924       SS1=DOT(7,7)-SPQ
23925       SS2=DOT(8,8)-SPQ
23926       SS3=DOT(9,9)-SPQ
23927       SS4=DOT(10,10)-SPQ
23928       SS5=DOT(11,11)-SPQ
23929       SS6=DOT(12,12)-SPQ
23930       SS7=DOT(13,13)
23931       DX(1)=SS1*SS6
23932       DX(2)=SS2*SS6
23933       DX(3)=SS2*SS4
23934       DX(4)=SS1*SS5
23935       DX(5)=SS3*SS5
23936       DX(6)=SS3*SS4
23937       DX(7)=SS7*SS1
23938       DX(8)=SS7*SS4
23939
23940 C...Define colour coefficients for g + g -> Q + Qbar + H.
23941       IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
23942         DO 140 I=1,3
23943           DO 130 J=1,3
23944             CLR(I,J)=16D0/3D0
23945             CLR(I+3,J+3)=16D0/3D0
23946             CLR(I,J+3)=-2D0/3D0
23947             CLR(I+3,J)=-2D0/3D0
23948   130     CONTINUE
23949   140   CONTINUE
23950         DO 160 L=1,2
23951           DO 150 I=1,3
23952             CLR(I,6+L)=-6D0
23953             CLR(I+3,6+L)=6D0
23954             CLR(6+L,I)=-6D0
23955             CLR(6+L,I+3)=6D0
23956   150     CONTINUE
23957   160   CONTINUE
23958         DO 180 K1=1,2
23959           DO 170 K2=1,2
23960             CLR(6+K1,6+K2)=12D0
23961   170     CONTINUE
23962   180   CONTINUE
23963
23964 C...Evaluate matrix elements for g + g -> Q + Qbar + H.
23965         FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
23966      &  X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
23967      &  X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
23968         FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
23969      &  *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
23970      &  X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
23971      &  X10)
23972         FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
23973      &  X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
23974      &  +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
23975      &  -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
23976      &  -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
23977      &  X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
23978         FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
23979      &  X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
23980      &  )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
23981      &  4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
23982      &  X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
23983         FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
23984      &  X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
23985      &  X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
23986      &  *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
23987      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
23988      &  X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
23989      &  +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
23990      &  X4*X6*X5)
23991         FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
23992      &  X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
23993      &  X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
23994      &  *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
23995      &  +X4*X9*X5+X4*X5**2)
23996         FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
23997      &  PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
23998      &  X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
23999      &  X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
24000      &  X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
24001      &  X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
24002         FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
24003      &  PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
24004      &  2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
24005      &  X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
24006      &  +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
24007      &  X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
24008      &  X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
24009      &  X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
24010      &  X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
24011         FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
24012      &  X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
24013         FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
24014      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
24015      &  X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
24016      &  X6)
24017         FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
24018      &  X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
24019      &  X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
24020      &  *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
24021      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
24022      &  *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
24023      &  X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
24024      &  X5+X4*X6*X5)
24025         FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
24026      &  *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
24027      &  2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
24028      &  X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
24029      &  X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
24030      &  *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
24031      &  X6**2)
24032         FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
24033      &  X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
24034      &  X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
24035      &  X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
24036      &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
24037      &  X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
24038      &  -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
24039      &  X4*X6*X5)
24040         FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24041      &  2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24042      &  X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
24043      &  X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
24044      &  *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
24045      &  +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24046      &  -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
24047      &  X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
24048      &  X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
24049      &  X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
24050      &  *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
24051         FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
24052      &  2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
24053      &  X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
24054      &  X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
24055      &  *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
24056      &  X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
24057      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
24058      &  X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
24059      &  *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
24060      &  X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
24061      &  X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
24062         FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
24063      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
24064      &  X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
24065         FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
24066      &  X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
24067      &  X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
24068      &  *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
24069      &  +X3*X8*X5+X3*X5**2)
24070         FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
24071      &  X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
24072      &  X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
24073      &  *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
24074      &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
24075      &  *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
24076      &  X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
24077      &  X5+X4*X6*X5)
24078         FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
24079      &  X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
24080      &  )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
24081      &  X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
24082      &  X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
24083         FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
24084      &  PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
24085      &  X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
24086      &  X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
24087      &  X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
24088      &  X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
24089      &  X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
24090      &  *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
24091      &  +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
24092         FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
24093      &  PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
24094      &  4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
24095      &  +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
24096      &  X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
24097      &  *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
24098         FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
24099      &  X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
24100      &  X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
24101         FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
24102      &  *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
24103      &  X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
24104      &  X10)
24105         FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
24106      &  X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
24107      &  +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
24108      &  -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
24109      &  -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
24110      &  X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
24111         FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
24112      &  *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
24113      &  X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
24114      &  X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
24115      &  X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
24116      &  X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
24117         FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
24118      &  *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
24119      &  +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
24120      &  *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
24121      &  X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
24122      &  *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
24123      &  *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
24124      &  *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
24125      &  X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
24126         FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
24127      &  X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
24128         FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
24129      &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
24130      &  X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
24131      &  X7)
24132         FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24133      &  4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24134      &  X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
24135      &  3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
24136      &  2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
24137      &  2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
24138      &  X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
24139      &  *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
24140      &  X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
24141      &  X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
24142      &  *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
24143         FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
24144      &  4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
24145      &  X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
24146      &  2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
24147      &  X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
24148      &  3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
24149      &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
24150      &  X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
24151      &  *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
24152      &  X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
24153      &  X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
24154         FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
24155      &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
24156      &  X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
24157         FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
24158      &  *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
24159      &  -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
24160      &  -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
24161      &  7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
24162      &  *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
24163      &  *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
24164      &  **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
24165      &  2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
24166         FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
24167      &  *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
24168      &  X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
24169      &  X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
24170      &  *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
24171      &  X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
24172         FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
24173      &  X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
24174      &  X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
24175      &  *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
24176      &  *X6)
24177         FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
24178      &  10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
24179      &  X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
24180      &  X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
24181      &  X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
24182      &  +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
24183      &  7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
24184         FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
24185      &  *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
24186      &  *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
24187      &  X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
24188      &  X8)
24189         FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24190      &  X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
24191      &  )+2*X2*(-X10*X5+X9*X6+X8*X7)
24192         FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24193      &  X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
24194      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
24195      &  X9*X5)
24196         FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
24197      &  X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
24198      &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
24199      &  X8*X5)
24200         FM(9,10)=0.5D0*(FMXX+FM(9,10))
24201         FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
24202      &  X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
24203      &  )+2*X5*(-X10*X2+X9*X3+X8*X4)
24204
24205 C...Repackage matrix elements.
24206         DO 200 I=1,8
24207           DO 190 J=1,8
24208             RM(I,J)=FM(I,J)
24209   190     CONTINUE
24210   200   CONTINUE
24211         RM(7,7)=FM(7,7)-2D0*FM(9,9)
24212         RM(7,8)=FM(7,8)-2D0*FM(9,10)
24213         RM(8,8)=FM(8,8)-2D0*FM(10,10)
24214
24215 C...Produce final result: matrix elements * colours * propagators.
24216         DO 220 I=1,8
24217           DO 210 J=I,8
24218             FAC=8D0
24219             IF(I.EQ.J)FAC=4D0
24220             WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
24221   210     CONTINUE
24222   220   CONTINUE
24223         WTQQBH=-WTQQBH/256D0
24224
24225       ELSE
24226 C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
24227         A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
24228      &  *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
24229      &  *X6+X8*X7)
24230         A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
24231      &  2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
24232      &  +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
24233      &  X5)
24234         A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
24235      &  X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
24236      &  *X9+X4*X8)
24237
24238 C...Produce final result: matrix elements * propagators.
24239         A11=A11/DX(7)**2
24240         A12=A12/(DX(7)*DX(8))
24241         A22=A22/DX(8)**2
24242         WTQQBH=-(A11+A22+2D0*A12)/8D0
24243       ENDIF
24244
24245       RETURN
24246       END
24247
24248 C*********************************************************************
24249
24250 *$ CREATE PYMSIN.FOR
24251 *COPY PYMSIN
24252 C...PYMSIN
24253 C...Initializes supersymmetry: finds sparticle masses and
24254 C...branching ratios and stores this information.
24255 C...AUTHOR: STEPHEN MRENNA
24256
24257       SUBROUTINE PYMSIN
24258
24259 C...Double precision and integer declarations.
24260       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24261       INTEGER PYK,PYCHGE,PYCOMP
24262 C...Parameter statement to help give large particle numbers.
24263       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24264 C...Commonblocks.
24265       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24266       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24267       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
24268       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24269       COMMON/PYINT4/MWID(500),WIDS(500,5)
24270       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24271       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24272      &SFMIX(16,4)
24273       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/,
24274      &/PYSSMT/
24275
24276 C...Local variables.
24277       INTEGER NSTR
24278       DOUBLE PRECISION ALFA,BETA
24279       DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT
24280       DOUBLE PRECISION PYALEM
24281       INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1
24282       INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0
24283       DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL
24284       DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5)
24285       DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM
24286       DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
24287       DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX
24288       DOUBLE PRECISION DELM,XMDIF,BRLIM
24289       DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
24290       DOUBLE PRECISION ARG,SGNMU,R,GAM
24291       INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4
24292       INTEGER IMSSM,KFHIGG
24293       INTEGER IRPRTY
24294       INTEGER KFSUSY(36)
24295       DATA KFSUSY/
24296      &1000001,2000001,1000002,2000002,1000003,2000003,
24297      &1000004,2000004,1000005,2000005,1000006,2000006,
24298      &1000011,2000011,1000012,2000012,1000013,2000013,
24299      &1000014,2000014,1000015,2000015,1000016,2000016,
24300      &1000021,1000022,1000023,1000025,1000035,1000024,
24301      &1000037,1000039,     25,     35,     36,     37/
24302
24303 C...Do nothing if SUSY not requested.
24304       IMSSM=IMSS(1)
24305       IF(IMSSM.EQ.0) RETURN
24306
24307 C...First part of routine: set masses and couplings.
24308
24309 C...Reset mixing values in sfermion sector to pure left/right.
24310       DO 100 I=1,16
24311         SFMIX(I,1)=1D0
24312         SFMIX(I,4)=1D0
24313         SFMIX(I,2)=0D0
24314         SFMIX(I,3)=0D0
24315   100 CONTINUE
24316
24317 C...Common couplings.
24318       TANB=RMSS(5)
24319       BETA=ATAN(TANB)
24320       COSB=COS(BETA)
24321       SINB=TANB*COSB
24322       COS2B=COS(2D0*BETA)
24323       ALFA=RMSS(18)
24324       XMW2=PMAS(24,1)**2
24325       XMZ2=PMAS(23,1)**2
24326       XW=PARU(102)
24327
24328 C...Define sparticle masses for a general MSSM simulation.
24329       IF(IMSSM.EQ.1) THEN
24330         IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
24331         DO 110 I=1,5,2
24332           KC=PYCOMP(KSUSY1+I)
24333           PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
24334           KC=PYCOMP(KSUSY2+I)
24335           PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
24336           KC=PYCOMP(KSUSY1+I+1)
24337           PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
24338           KC=PYCOMP(KSUSY2+I+1)
24339           PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
24340   110   CONTINUE
24341         XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
24342         IF(XARG.LT.0D0) THEN
24343           WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24344      &    ' FROM THE SUM RULE. '
24345           WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
24346           RETURN
24347         ELSE
24348           XARG=SQRT(XARG)
24349         ENDIF
24350         DO 120 I=11,15,2
24351           PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
24352           PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
24353           PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24354           PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24355   120   CONTINUE
24356         IF(IMSS(8).EQ.1) THEN
24357           RMSS(13)=RMSS(6)
24358           RMSS(14)=RMSS(7)
24359         ENDIF
24360
24361 C...Alternatively derive masses from SUGRA relations.
24362       ELSEIF(IMSSM.EQ.2) THEN
24363         CALL PYAPPS
24364       ENDIF
24365
24366 C...Add in extra D-term contributions.
24367       IF(IMSS(7).EQ.1) THEN
24368         R=0.43D0
24369         DX=RMSS(23)
24370         DY=RMSS(24)
24371         DS=RMSS(25)
24372         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24373         WRITE(MSTU(11),*) 'C  NEW DTERMS ADDED TO SCALAR MASSES   '
24374         WRITE(MSTU(11),*) 'C   IN A U(B-L) THEORY                 '
24375         WRITE(MSTU(11),*) 'C   DX = ',DX
24376         WRITE(MSTU(11),*) 'C   DY = ',DY
24377         WRITE(MSTU(11),*) 'C   DS = ',DS
24378         WRITE(MSTU(11),*) 'C                                      '
24379         DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
24380         WRITE(MSTU(11),*) 'C   DY AT THE WEAK SCALE = ',DY
24381         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24382         DQ2=DY/6D0-DX/3D0-DS/3D0
24383         DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
24384         DD2=DY/3D0+DX-2D0*DS/3D0
24385         DL2=-DY/2D0+DX-2D0*DS/3D0
24386         DE2=DY-DX/3D0-DS/3D0
24387         DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
24388         DHD2=-DY/2D0-2D0*DX/3D0+DS
24389         DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
24390      &  /ABS(COS2B)
24391         DMA2 = 2D0*DMU2+DHU2+DHD2
24392         DO 130 I=1,5,2
24393           KC=PYCOMP(KSUSY1+I)
24394           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24395           KC=PYCOMP(KSUSY2+I)
24396           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
24397           KC=PYCOMP(KSUSY1+I+1)
24398           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
24399           KC=PYCOMP(KSUSY2+I+1)
24400           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
24401   130   CONTINUE
24402         DO 140 I=11,15,2
24403           KC=PYCOMP(KSUSY1+I)
24404           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24405           KC=PYCOMP(KSUSY2+I)
24406           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
24407           KC=PYCOMP(KSUSY1+I+1)
24408           PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
24409   140   CONTINUE
24410         IF(RMSS(4)**2+DMU2.LT.0D0) THEN
24411           WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
24412           STOP
24413         ENDIF
24414         SGNMU=SIGN(1D0,RMSS(4))
24415         RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
24416         ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
24417         RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
24418         ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
24419         RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
24420         ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
24421         RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
24422         ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
24423         RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
24424         ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
24425         RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
24426         IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
24427           WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
24428           STOP
24429         ENDIF
24430         RMSS(19)=SQRT(RMSS(19)**2+DMA2)
24431         RMSS(6)=SQRT(RMSS(6)**2+DL2)
24432         RMSS(7)=SQRT(RMSS(7)**2+DE2)
24433         WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
24434         WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
24435         WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
24436         WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
24437         WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
24438       ENDIF
24439
24440 C...Fix the third generation sfermions.
24441       CALL PYTHRG
24442       XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B)
24443       IF(XARG.LT.0D0) THEN
24444         WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//
24445      &  ' THE SUM RULE. '
24446         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
24447         RETURN
24448       ELSE
24449         PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
24450       ENDIF
24451
24452 C...Fix the neutralino--chargino--gluino sector.
24453       CALL PYINOM
24454
24455 C...Fix the Higgs sector.
24456       CALL PYHGGM(ALFA)
24457
24458 C...Choose the Gunion-Haber convention.
24459       ALFA=-ALFA
24460       RMSS(18)=ALFA
24461
24462 C...Print information on mass parameters.
24463       IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
24464         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24465         WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
24466         WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
24467         WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
24468         WRITE(MSTU(11),*) ' TANB=',RMSS(5)
24469         WRITE(MSTU(11),*) ' MU = ',RMSS(4)
24470         WRITE(MSTU(11),*) ' AT = ',RMSS(16)
24471         WRITE(MSTU(11),*) ' MA = ',RMSS(19)
24472         WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
24473         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24474       ENDIF
24475       IF(IMSS(20).EQ.1) THEN
24476         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24477         WRITE(MSTU(11),*) ' DEBUG MODE '
24478         WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
24479      &  UMIX(2,1),UMIX(2,2)
24480         WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
24481      &  VMIX(2,1),VMIX(2,2)
24482         WRITE(MSTU(11),*) ' ZMIX = ',ZMIX
24483         WRITE(MSTU(11),*) ' ALFA = ',ALFA
24484         WRITE(MSTU(11),*) ' BETA = ',BETA
24485         WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
24486         WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
24487         WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
24488       ENDIF
24489
24490 C...Set up the Higgs couplings - needed here since initialization
24491 C...in PYINRE did not yet occur when PYWIDT is called below.
24492       AL=ALFA
24493       BE=BETA
24494       SINA=SIN(AL)
24495       COSA=COS(AL)
24496       COSB=COS(BE)
24497       SINB=TANB*COSB
24498 C...tanb (used for H+)
24499       PARU(141)=TANB
24500
24501 C...Firstly: h
24502 C...Coupling to d-type quarks
24503       PARU(161)=SINA/COSB
24504 C...Coupling to u-type quarks
24505       PARU(162)=-COSA/SINB
24506 C...Coupling to leptons
24507       PARU(163)=PARU(161)
24508 C...Coupling to Z
24509       PARU(164)=SIN(BE-AL)
24510 C...Coupling to W
24511       PARU(165)=PARU(164)
24512 C...Coupling to H+
24513       PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW)
24514
24515 C...Secondly: H
24516 C...Coupling to d-type quarks
24517       PARU(171)=-COSA/COSB
24518 C...Coupling to u-type quarks
24519       PARU(172)=-SINA/SINB
24520 C...Coupling to leptons
24521       PARU(173)=PARU(171)
24522 C...Coupling to Z
24523       PARU(174)=COS(BE-AL)
24524 C...Coupling to W
24525       PARU(175)=PARU(174)
24526 C...Coupling to h
24527       PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
24528 C...Coupling to A
24529       PARU(177)=COS(2D0*BE)*COS(BE+AL)
24530 C...Coupling to H+
24531       PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW)
24532
24533 C...Thirdly, A
24534 C...Coupling to d-type quarks
24535       PARU(181)=TANB
24536 C...Coupling to u-type quarks
24537       PARU(182)=1D0/PARU(181)
24538 C...Coupling to leptons
24539       PARU(183)=PARU(181)
24540       PARU(184)=0D0
24541       PARU(185)=0D0
24542 C...Coupling to Z h
24543       PARU(186)=COS(BE-AL)
24544 C...Coupling to Z H
24545       PARU(187)=SIN(BE-AL)
24546       PARU(188)=0D0
24547       PARU(189)=0D0
24548       PARU(190)=0D0
24549
24550 C...Finally: H+
24551 C...Coupling to W h
24552       PARU(195)=COS(BE-AL)
24553
24554 C...Tell that all Higgs couplings have been set.
24555       MSTP(4)=1
24556
24557 C...Second part of routine: set decay modes and branching ratios.
24558
24559 C...Allow chi10 -> gravitino + gamma or not.
24560       KC=PYCOMP(KSUSY1+39)
24561       IF( IMSS(11) .NE. 0 ) THEN
24562         PMAS(KC,1)=RMSS(21)/1000000000D0
24563         PMAS(KC,2)=0.0001D0
24564         IRPRTY=0
24565         WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
24566       ELSE
24567         PMAS(KC,1)=9999D0
24568         IRPRTY=1
24569       ENDIF
24570
24571 C...Loop over sparticle and Higgs species.
24572       PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
24573       DO 200 I=1,36
24574         KF=KFSUSY(I)
24575         KC=PYCOMP(KF)
24576         LKNT=0
24577
24578 C...Sfermion decays.
24579         IF(I.LE.24) THEN
24580 C...First check to see if sneutrino is lighter than chi10.
24581           IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
24582      &    PMAS(KC,1).LT.PMCHI1) THEN
24583           ELSE
24584             CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
24585           ENDIF
24586
24587 C...Gluino decays.
24588         ELSEIF(I.EQ.25) THEN
24589           CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
24590
24591 C...Neutralino decays.
24592         ELSEIF(I.GE.26.AND.I.LE.29) THEN
24593           CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
24594 C...chi10 stable or chi10 -> gravitino + gamma.
24595           IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
24596             PMAS(KC,2)=1D-6
24597             MDCY(KC,1)=0
24598             MWID(KC)=0
24599           ENDIF
24600
24601 C...Chargino decays.
24602         ELSEIF(I.GE.30.AND.I.LE.31) THEN
24603           CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
24604
24605 C...Gravitino is stable.
24606         ELSEIF(I.EQ.32) THEN
24607           MDCY(KC,1)=0
24608           MWID(KC)=0
24609
24610 C...Higgs decays.
24611         ELSEIF(I.GE.33.AND.I.LE.36) THEN
24612 C...Calculate decays to non-SUSY particles.
24613           CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
24614           LKNT=0
24615           DO 150 I1=0,100
24616             XLAM(I1)=0D0
24617   150     CONTINUE
24618           DO 170 I1=1,MDCY(KC,3)
24619             K1=MDCY(KC,2)+I1-1
24620             IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
24621      &      IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170
24622             XLAM(I1)=WDTP(I1)
24623             XLAM(0)=XLAM(0)+XLAM(I1)
24624             DO 160 J1=1,3
24625               IDLAM(I1,J1)=KFDP(K1,J1)
24626   160       CONTINUE
24627             LKNT=LKNT+1
24628   170     CONTINUE
24629 C...Add the decays to SUSY particles.
24630           CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
24631         ENDIF
24632
24633 C...Set stable particles.
24634         IF(LKNT.EQ.0) THEN
24635           MDCY(KC,1)=0
24636           MWID(KC)=0
24637           PMAS(KC,2)=1D-6
24638           PMAS(KC,3)=1D-5
24639           PMAS(KC,4)=0D0
24640
24641 C...Store branching ratios in the standard tables.
24642         ELSE
24643           IDC=MDCY(KC,2)+MDCY(KC,3)-1
24644           DELM=1D6
24645           DO 190 IL=1,LKNT
24646             IDCSV=IDC
24647   180       IDC=IDC+1
24648             IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
24649             IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
24650      &      KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
24651               BRAT(IDC)=XLAM(IL)/XLAM(0)
24652               XMDIF=PMAS(KC,1)
24653               IF(MDME(IDC,1).GE.1) THEN
24654                 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
24655      &          PMAS(PYCOMP(KFDP(IDC,2)),1)
24656                 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
24657      &          PMAS(PYCOMP(KFDP(IDC,3)),1)
24658               ENDIF
24659               IF(I.LE.32) THEN
24660                 IF(XMDIF.GE.0D0) THEN
24661                   DELM=MIN(DELM,XMDIF)
24662                 ELSE
24663                   WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
24664                   WRITE(MSTU(11),*) ' KF = ',KF
24665                   WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
24666                 ENDIF
24667               ENDIF
24668               GOTO 190
24669             ELSEIF(IDC.EQ.IDCSV) THEN
24670               WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
24671      &        'channel not recognized:'
24672               WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3)
24673               GOTO 190
24674             ELSE
24675               GOTO 180
24676             ENDIF
24677   190     CONTINUE
24678
24679 C...Store width, cutoff and lifetime.
24680           PMAS(KC,2)=XLAM(0)
24681           IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
24682             PMAS(KC,3)=PMAS(KC,2)*10D0
24683           ELSE
24684             PMAS(KC,3)=0.95D0*DELM
24685           ENDIF
24686           IF(PMAS(KC,2).NE.0D0) THEN
24687             PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
24688           ENDIF
24689         ENDIF
24690   200 CONTINUE
24691
24692       RETURN
24693       END
24694
24695 C*********************************************************************
24696
24697 *$ CREATE PYAPPS.FOR
24698 *COPY PYAPPS
24699 C...PYAPPS
24700 C...Uses approximate analytical formulae to determine the full set of
24701 C...MSSM parameters from SUGRA input.
24702 C...See M. Drees and S.P. Martin, hep-ph/9504124
24703
24704       SUBROUTINE PYAPPS
24705
24706 C...Double precision and integer declarations.
24707       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24708       INTEGER PYK,PYCHGE,PYCOMP
24709 C...Parameter statement to help give large particle numbers.
24710       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24711 C...Commonblocks.
24712       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24713       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24714       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24715       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
24716
24717       XMT=PMAS(6,1)
24718       XMZ2=PMAS(23,1)**2
24719       XMW2=PMAS(24,1)**2
24720       TANB=RMSS(5)
24721       BETA=ATAN(TANB)
24722       XW=PARU(102)
24723       XMG=RMSS(1)
24724       XMG2=XMG*XMG
24725       XM0=RMSS(8)
24726       XM02=XM0*XM0
24727       AT=-RMSS(16)
24728       RMSS(15)=AT
24729       RMSS(17)=AT
24730       COSB=COS(BETA)
24731       SINB=TANB*COSB
24732
24733       DTERM=XMZ2*COS(2D0*BETA)
24734       XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
24735       XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
24736       RMSS(6)=XMEL
24737       RMSS(7)=XMER
24738       XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
24739       XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
24740       XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
24741       XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
24742       DO 100 I=1,5,2
24743         PMAS(PYCOMP(KSUSY1+I),1)=XMDL
24744         PMAS(PYCOMP(KSUSY2+I),1)=XMDR
24745         PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
24746         PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
24747   100 CONTINUE
24748       XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
24749       IF(XARG.LT.0D0) THEN
24750         WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
24751      &  ' FROM THE SUM RULE. '
24752         WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
24753         RETURN
24754       ELSE
24755         XARG=SQRT(XARG)
24756       ENDIF
24757       DO 110 I=11,15,2
24758         PMAS(PYCOMP(KSUSY1+I),1)=XMEL
24759         PMAS(PYCOMP(KSUSY2+I),1)=XMER
24760         PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
24761         PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
24762   110 CONTINUE
24763       XMNU=XARG
24764
24765       RMT=PYRNMT(XMT)
24766       XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
24767      &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
24768       RMB=3D0
24769       XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
24770      &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
24771       XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
24772       ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
24773      &SINB)**2)
24774       RMSS(16)=-ATP
24775       XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
24776       XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
24777       XMU=SIGN(SQRT(XMU2),RMSS(4))
24778       RMSS(4)=XMU
24779       RMSS(19)=SQRT(XMA2)
24780       ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
24781       IF(ARG.GT.0D0) THEN
24782         RMSS(14)=SQRT(ARG)
24783       ELSE
24784         WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 '
24785         STOP
24786       ENDIF
24787       ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
24788       IF(ARG.GT.0D0) THEN
24789         RMSS(13)=SQRT(ARG)
24790       ELSE
24791         WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 '
24792         STOP
24793       ENDIF
24794       ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
24795       IF(ARG.GT.0D0) THEN
24796         RMSS(10)=SQRT(ARG)
24797       ELSE
24798         RMSS(10)=-SQRT(-ARG)
24799       ENDIF
24800       ARG=PYRNMQ(2,-2D0*XTOP/3D0)
24801       IF(ARG.GT.0D0) THEN
24802         RMSS(12)=SQRT(ARG)
24803       ELSE
24804         RMSS(12)=-SQRT(-ARG)
24805       ENDIF
24806       ARG=PYRNMQ(3,-2D0*XBOT/3D0)
24807       IF(ARG.GT.0D0) THEN
24808         RMSS(11)=SQRT(ARG)
24809       ELSE
24810         RMSS(11)=-SQRT(-ARG)
24811       ENDIF
24812
24813       RETURN
24814       END
24815
24816 C*********************************************************************
24817
24818 *$ CREATE PYRNMQ.FOR
24819 *COPY PYRNMQ
24820 C...PYRNMQ
24821 C...Determines the running mass of quarks.
24822
24823       FUNCTION PYRNMQ(ID,DTERM)
24824
24825 C...Double precision and integer declarations.
24826       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24827       INTEGER PYK,PYCHGE,PYCOMP
24828 C...Commonblock.
24829       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24830       SAVE /PYMSSM/
24831
24832 C...Local variables.
24833       DOUBLE PRECISION PI,R
24834       DOUBLE PRECISION TOL
24835       DOUBLE PRECISION CI(3)
24836       EXTERNAL PYALPS
24837       DATA TOL/0.001D0/
24838       DATA PI,R/3.141592654D0,.61803399D0/
24839       DATA CI/0.47D0,0.07D0,0.02D0/
24840
24841       C=1D0-R
24842       CA=CI(ID)
24843       AG=(0.71D0)**2/4D0/PI
24844       AG=RMSS(20)
24845       XM0=RMSS(8)
24846       XMG=RMSS(1)
24847       XM02=XM0*XM0
24848       XMG2=XMG*XMG
24849
24850       AS=PYALPS(XM02+6D0*XMG2)
24851       CG=8D0/9D0*((AS/AG)**2-1D0)
24852       BX=XM02+(CA+CG)*XMG2+DTERM
24853       AX=MIN(50D0**2,0.5D0*BX)
24854       CX=MAX(2000D0**2,2D0*BX)
24855
24856       X0=AX
24857       X3=CX
24858       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24859         X1=BX
24860         X2=BX+C*(CX-BX)
24861       ELSE
24862         X2=BX
24863         X1=BX-C*(BX-AX)
24864       ENDIF
24865       AS1=PYALPS(X1)
24866       CG=8D0/9D0*((AS1/AG)**2-1D0)
24867       F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24868       AS2=PYALPS(X2)
24869       CG=8D0/9D0*((AS2/AG)**2-1D0)
24870       F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24871   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24872         IF(F2.LT.F1) THEN
24873           X0=X1
24874           X1=X2
24875           X2=R*X1+C*X3
24876           F1=F2
24877           AS2=PYALPS(X2)
24878           CG=8D0/9D0*((AS2/AG)**2-1D0)
24879           F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
24880         ELSE
24881           X3=X2
24882           X2=X1
24883           X1=R*X2+C*X0
24884           F2=F1
24885           AS1=PYALPS(X1)
24886           CG=8D0/9D0*((AS1/AG)**2-1D0)
24887           F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
24888         ENDIF
24889         GOTO 100
24890       ENDIF
24891       IF(F1.LT.F2) THEN
24892         PYRNMQ=X1
24893         XMIN=X1
24894       ELSE
24895         PYRNMQ=X2
24896         XMIN=X2
24897       ENDIF
24898
24899       RETURN
24900       END
24901
24902 C*********************************************************************
24903
24904 *$ CREATE PYRNMT.FOR
24905 *COPY PYRNMT
24906 C...PYRNMT
24907 C...Determines the running mass of the top quark.
24908
24909       FUNCTION PYRNMT(XMT)
24910
24911 C...Double precision and integer declarations.
24912       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24913       INTEGER PYK,PYCHGE,PYCOMP
24914 C...Commonblock.
24915       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24916       SAVE /PYMSSM/
24917
24918 C...Local variables.
24919       DOUBLE PRECISION XMT
24920       DOUBLE PRECISION PI,R
24921       DOUBLE PRECISION TOL
24922       EXTERNAL PYALPS
24923       DATA TOL/0.001D0/
24924       DATA PI,R/3.141592654D0,0.61803399D0/
24925
24926       C=1D0-R
24927
24928       BX=XMT
24929       AX=MIN(50D0,BX*0.5D0)
24930       CX=MAX(300D0,2D0*BX)
24931
24932       X0=AX
24933       X3=CX
24934       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
24935         X1=BX
24936         X2=BX+C*(CX-BX)
24937       ELSE
24938         X2=BX
24939         X1=BX-C*(BX-AX)
24940       ENDIF
24941       AS1=PYALPS(X1**2)/PI
24942       F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24943       AS2=PYALPS(X2**2)/PI
24944       F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24945   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
24946         IF(F2.LT.F1) THEN
24947           X0=X1
24948           X1=X2
24949           X2=R*X1+C*X3
24950           F1=F2
24951           AS2=PYALPS(X2**2)/PI
24952           F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2)
24953         ELSE
24954           X3=X2
24955           X2=X1
24956           X1=R*X2+C*X0
24957           F2=F1
24958           AS1=PYALPS(X1**2)/PI
24959           F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1)
24960         ENDIF
24961         GOTO 100
24962       ENDIF
24963       IF(F1.LT.F2) THEN
24964         PYRNMT=X1
24965         XMIN=X1
24966       ELSE
24967         PYRNMT=X2
24968         XMIN=X2
24969       ENDIF
24970
24971       RETURN
24972       END
24973
24974 C*********************************************************************
24975
24976 *$ CREATE PYTHRG.FOR
24977 *COPY PYTHRG
24978 C...PYTHRG
24979 C...Calculates the mass eigenstates of the third generation sfermions.
24980 C...Created:  5-31-96
24981
24982       SUBROUTINE PYTHRG
24983
24984 C...Double precision and integer declarations.
24985       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24986       INTEGER PYK,PYCHGE,PYCOMP
24987 C...Parameter statement to help give large particle numbers.
24988       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
24989 C...Commonblocks.
24990       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24991       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24992       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24993       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24994      &SFMIX(16,4)
24995       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
24996
24997 C...Local variables.
24998       DOUBLE PRECISION BETA
24999       DOUBLE PRECISION PYRNMT
25000       DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
25001       DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
25002       DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
25003       DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL
25004       INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
25005       INTEGER IF,I,J,II,JJ,IT,L
25006       LOGICAL DTERM
25007       DATA SMALL/1D-3/
25008       DATA ID1/10,10,13/
25009       DATA ID2/5,6,15/
25010       DATA ID3/15,16,17/
25011       DATA ID4/11,12,14/
25012       DATA DTERM/.TRUE./
25013
25014       XMZ2=PMAS(23,1)**2
25015       XMW2=PMAS(24,1)**2
25016       TANB=RMSS(5)
25017       XMU=-RMSS(4)
25018       BETA=ATAN(TANB)
25019       COS2B=COS(2D0*BETA)
25020
25021 C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
25022
25023       IOPT=IMSS(5)
25024       IF(IOPT.EQ.1) THEN
25025         CTT=RMSS(27)
25026         CTT2=CTT**2
25027         STT2=1D0-CTT2
25028         STT=SQRT(STT2)
25029         XM12=RMSS(12)**2
25030         XM22=RMSS(10)**2
25031         XMQL2=CTT2*XM12+STT2*XM22
25032         XMQR2=STT2*XM12+CTT2*XM22
25033         XMFR=PMAS(6,1)
25034         XMF2=PYRNMT(XMFR)**2
25035         ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25036         ATMT=SQRT(XMF2)*(ATOP+XMU/TANB)
25037         XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25038         IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25039          STT=-STT
25040          ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25041         ENDIF
25042         RMSS(16)=ATOP
25043 C......SUBTRACT OUT D-TERM AND FERMION MASS
25044         XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
25045         XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
25046         IF(XMQL2.GE.0D0) THEN
25047           RMSS(10)=SQRT(XMQL2)
25048         ELSE
25049           RMSS(10)=-SQRT(-XMQL2)
25050         ENDIF
25051         IF(XMQR2.GE.0D0) THEN
25052           RMSS(12)=SQRT(XMQR2)
25053         ELSE
25054           RMSS(12)=-SQRT(-XMQR2)
25055         ENDIF
25056 C SAME FOR SBOTTOM SQUARK
25057         CTT=RMSS(26)
25058         CTT2=CTT**2
25059         STT2=1D0-CTT2
25060         STT=MAX(SQRT(STT2),1D-6)
25061         XMF=3D00
25062         XMF2=XMF**2
25063         XM12=RMSS(11)**2
25064         XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
25065         IF(ABS(CTT).EQ.1D0) THEN
25066           XM22=XM12
25067           XM12=XMQL2
25068           XMQR2=XM22
25069         ELSEIF(CTT.EQ.0D0) THEN
25070           XM22=XMQL2
25071           XMQR2=XM12
25072         ELSE
25073           XM22=(XMQL2-CTT2*XM12)/STT2
25074           XMQR2=STT2*XM12+CTT2*XM22
25075         ENDIF
25076         ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25077         ATMT=SQRT(XMF2)*(ABOT+XMU*TANB)
25078         XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
25079         IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
25080           STT=-STT
25081           ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
25082         ENDIF
25083         RMSS(15)=ABOT
25084 C......SUBTRACT OUT D-TERM AND FERMION MASS
25085         XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
25086         IF(XMQR2.GE.0D0) THEN
25087           RMSS(11)=SQRT(XMQR2)
25088         ELSE
25089           RMSS(11)=-SQRT(-XMQR2)
25090         ENDIF
25091       ENDIF
25092
25093       DO 170 L=1,3
25094         AMQL=RMSS(ID1(L))
25095         IF(AMQL.LT.0D0) THEN
25096           XMQL2=-AMQL**2
25097         ELSE
25098           XMQL2=AMQL**2
25099         ENDIF
25100         IF=ID2(L)
25101         XMF=PMAS(IF,1)
25102         IF(L.EQ.1) XMF=3D0
25103         IF(L.EQ.2) XMF=PYRNMT(XMF)
25104         XMF2=XMF**2
25105         ATR=RMSS(ID3(L))
25106         AMQR=RMSS(ID4(L))
25107         IF(AMQR.LT.0D0) THEN
25108           XMQR2=-AMQR**2
25109         ELSE
25110           XMQR2=AMQR**2
25111         ENDIF
25112         AM2(1,1)=XMQL2+XMF2
25113         AM2(2,2)=XMQR2+XMF2
25114         IF(DTERM) THEN
25115           IF(L.EQ.1) THEN
25116             AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
25117             AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
25118             AM2(1,2)=XMF*(ATR+XMU*TANB)
25119           ELSEIF(L.EQ.2) THEN
25120             AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
25121             AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
25122             AM2(1,2)=XMF*(ATR+XMU/TANB)
25123           ELSEIF(L.EQ.3) THEN
25124             IF(IMSS(8).EQ.1) THEN
25125               AM2(1,1)=RMSS(6)**2
25126               AM2(2,2)=RMSS(7)**2
25127               AM2(1,2)=0D0
25128               RMSS(13)=RMSS(6)
25129               RMSS(14)=RMSS(7)
25130             ELSE
25131               AM2(1,2)=XMF*(ATR+XMU*TANB)
25132             ENDIF
25133           ENDIF
25134         ENDIF
25135         AM2(2,1)=AM2(1,2)
25136         SAME=0.5D0*(AM2(1,1)+AM2(2,2))
25137         DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
25138         XMF12=SAME-DIFF
25139         XMF22=SAME+DIFF
25140         IF(XMF12.LT.0D0) THEN
25141           WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION '
25142           STOP
25143         ENDIF
25144         IT=0
25145         IF(XMF22-XMF12.GT.0D0) THEN
25146           RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12))
25147           RT(2,2) = RT(1,1)
25148           RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12))
25149           RT(2,1) = -RT(1,2)
25150         ELSE
25151           RT(1,1) = 1D0
25152           RT(2,2) = RT(1,1)
25153           RT(1,2) = 0D0
25154           RT(2,1) = -RT(1,2)
25155         ENDIF
25156   100   CONTINUE
25157         IT=IT+1
25158
25159         DO 140 I=1,2
25160           DO 130 JJ=1,2
25161             DI(I,JJ)=0D0
25162             DO 120 II=1,2
25163               DO 110 J=1,2
25164                 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
25165   110         CONTINUE
25166   120       CONTINUE
25167   130     CONTINUE
25168   140   CONTINUE
25169
25170         IF(DI(1,1).GT.DI(2,2)) THEN
25171           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
25172           WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
25173           WRITE(MSTU(11),*) AM2
25174           WRITE(MSTU(11),*) DI
25175           WRITE(MSTU(11),*) RT
25176           DI(1,1)=-RT(2,1)
25177           DI(2,2)=RT(1,2)
25178           DI(1,2)=-RT(2,2)
25179           DI(2,1)=RT(1,1)
25180           DO 160 I=1,2
25181             DO 150 J=1,2
25182               RT(I,J)=DI(I,J)
25183   150       CONTINUE
25184   160     CONTINUE
25185           GOTO 100
25186         ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
25187           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25188      &    ' OFF DIAGONAL ELEMENTS '
25189           WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
25190           WRITE(MSTU(11),*) DI
25191           WRITE(MSTU(11),*) ' ROTATION = ',RT
25192 C...STOP
25193         ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
25194           WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
25195      &    ' NEGATIVE MASSES '
25196           STOP
25197         ENDIF
25198         PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
25199         PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
25200         SFMIX(IF,1)=RT(1,1)
25201         SFMIX(IF,2)=RT(1,2)
25202         SFMIX(IF,3)=RT(2,1)
25203         SFMIX(IF,4)=RT(2,2)
25204   170 CONTINUE
25205
25206       RETURN
25207       END
25208
25209 C*********************************************************************
25210
25211 *$ CREATE PYINOM.FOR
25212 *COPY PYINOM
25213 C...PYINOM
25214 C...Finds the mass eigenstates and mixing matrices for neutralinos
25215 C...and charginos.
25216
25217       SUBROUTINE PYINOM
25218
25219 C...Double precision and integer declarations.
25220       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25221       INTEGER PYK,PYCHGE,PYCOMP
25222 C...Parameter statement to help give large particle numbers.
25223       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25224 C...Commonblocks.
25225       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25226       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25227       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25228       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25229      &SFMIX(16,4)
25230       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
25231
25232 C...Local variables.
25233       DOUBLE PRECISION XMW,XMZ
25234       DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4)
25235       DOUBLE PRECISION ZP(4,4)
25236       DOUBLE PRECISION DETX,XI(2,2)
25237       DOUBLE PRECISION XXX,YYY,XMH,XML
25238       DOUBLE PRECISION COSW,SINW
25239       DOUBLE PRECISION XMU
25240       DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2
25241       DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
25242       DOUBLE PRECISION XM1,XM2,XM3,BETA
25243       DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2
25244       DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
25245       DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
25246       DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
25247       DOUBLE PRECISION PYALPS,PYALEM
25248       DOUBLE PRECISION PYRNM3
25249       INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4)
25250       DATA KFNCHI/1000022,1000023,1000025,1000035/
25251
25252       IOPT=IMSS(2)
25253       IF(IMSS(1).EQ.2) THEN
25254         IOPT=1
25255       ENDIF
25256 C...M1, M2, AND M3 ARE INDEPENDENT
25257       IF(IOPT.EQ.0) THEN
25258         XM1=RMSS(1)
25259         XM2=RMSS(2)
25260         XM3=RMSS(3)
25261       ELSEIF(IOPT.GE.1) THEN
25262         Q2=PMAS(23,1)**2
25263         AEM=PYALEM(Q2)
25264         A2=AEM/PARU(102)
25265         A1=AEM/(1D0-PARU(102))
25266         XM1=RMSS(1)
25267         XM2=RMSS(2)
25268         IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
25269         IF(IOPT.EQ.1) THEN
25270           XM2=XM1*A2/A1*3D0/5D0
25271         ELSEIF(IOPT.EQ.3) THEN
25272           XM1=XM2*5D0/3D0*A1/A2
25273         ENDIF
25274         XM3=PYRNM3(XM2/A2)
25275         IF(XM3.LE.0D0) THEN
25276           WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
25277           STOP
25278         ENDIF
25279       ENDIF
25280
25281 C...GLUINO MASS
25282       IF(IMSS(3).EQ.1) THEN
25283         PMAS(PYCOMP(KSUSY1+21),1)=XM3
25284       ELSE
25285         AQ=0D0
25286         DO 110 I=1,4
25287           DO 100 ILR=1,2
25288             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25289             AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
25290      &      +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
25291   100     CONTINUE
25292   110   CONTINUE
25293
25294         DO 130 I=5,6
25295           DO 120 ILR=1,2
25296             RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
25297             RM2=PMAS(I,1)**2/XM3**2
25298             ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
25299             IF(ARG.GE.0D0) THEN
25300               X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
25301               AX0=ABS(X0)
25302               X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
25303               AX1=ABS(X1)
25304               IF(X0.EQ.1D0) THEN
25305                 AT=-1D0
25306                 BT=0.25D0
25307               ELSEIF(X0.EQ.0D0) THEN
25308                 AT=0D0
25309                 BT=-0.25D0
25310               ELSE
25311                 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
25312      &          0.5D0*X0**2*LOG(AX0)
25313                 BT=(-1D0-2D0*X0)/4D0
25314               ENDIF
25315               IF(X1.EQ.1D0) THEN
25316                 AT=-1D0+AT
25317                 BT=0.25D0+BT
25318               ELSEIF(X1.EQ.0D0) THEN
25319                 AT=0D0+AT
25320                 BT=-0.25D0+BT
25321               ELSE
25322                 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
25323      &          X1**2*LOG(AX1)+AT
25324                 BT=(-1D0-2D0*X1)/4D0+BT
25325               ENDIF
25326               AQ=AQ+AT+BT
25327             ELSE
25328               X0=0.5D0*(1D0+RM2-RM1)
25329               Y0=-0.5D0*SQRT(-ARG)
25330               AMGX0=SQRT(X0**2+Y0**2)
25331               AM1X0=SQRT((1D0-X0)**2+Y0**2)
25332               ARGX0=ATAN2(-X0,-Y0)
25333               AR1X0=ATAN2(1D0-X0,Y0)
25334               X1=X0
25335               Y1=-Y0
25336               AMGX1=AMGX0
25337               AM1X1=AM1X0
25338               ARGX1=ATAN2(-X1,-Y1)
25339               AR1X1=ATAN2(1D0-X1,Y1)
25340               AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
25341      &        +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
25342               BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
25343               AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
25344      &        +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
25345               BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
25346               AQ=AQ+AT+BT
25347             ENDIF
25348   120     CONTINUE
25349   130   CONTINUE
25350         PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))*
25351      &  (15D0+AQ))
25352       ENDIF
25353
25354 C...NEUTRALINO MASSES
25355       XMZ=PMAS(23,1)
25356       XMW=PMAS(24,1)
25357       XMU=RMSS(4)
25358       SINW=SQRT(PARU(102))
25359       COSW=SQRT(1D0-PARU(102))
25360       TANB=RMSS(5)
25361       BETA=ATAN(TANB)
25362       COSB=COS(BETA)
25363       SINB=TANB*COSB
25364       AR(1,1) = XM1
25365       AR(2,2) = XM2
25366       AR(3,3) = 0D0
25367       AR(4,4) = 0D0
25368       AR(1,2) = 0D0
25369       AR(2,1) = 0D0
25370       AR(1,3) = -XMZ*SINW*COSB
25371       AR(3,1) = AR(1,3)
25372       AR(1,4) = XMZ*SINW*SINB
25373       AR(4,1) = AR(1,4)
25374       AR(2,3) = XMZ*COSW*COSB
25375       AR(3,2) = AR(2,3)
25376       AR(2,4) = -XMZ*COSW*SINB
25377       AR(4,2) = AR(2,4)
25378       AR(3,4) = -XMU
25379       AR(4,3) = -XMU
25380       CALL PYEIG4(AR,WR,ZR)
25381       DO 150 I=1,4
25382         SMZ(I)=WR(I)
25383         PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
25384         DO 140 J=1,4
25385           ZMIX(I,J)=ZR(I,J)
25386           IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
25387   140   CONTINUE
25388   150 CONTINUE
25389
25390 C...CHARGINO MASSES
25391       AR(1,1) = XM2
25392       AR(2,2) = XMU
25393       AR(1,2) = SQRT(2D0)*XMW*SINB
25394       AR(2,1) = SQRT(2D0)*XMW*COSB
25395       TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2
25396       TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2
25397       TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)*
25398      &(AR(1,2)**2+AR(2,1)**2)+
25399      &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1)
25400       DISCR=TERMC
25401       IF(DISCR.LT.0D0) THEN
25402         WRITE(MSTU(11),*) ' PROBLEM WITH DISCR '
25403       ELSE
25404         DISCR=SQRT(DISCR)
25405       ENDIF
25406       XML2=0.5D0*(TERMB-DISCR)
25407       XMH2=0.5D0*(TERMB+DISCR)
25408       XML=SQRT(XML2)
25409       XMH=SQRT(XMH2)
25410       PMAS(PYCOMP(KSUSY1+24),1)=XML
25411       PMAS(PYCOMP(KSUSY1+37),1)=XMH
25412       SMW(1)=XML
25413       SMW(2)=XMH
25414       XXX=AR(1,1)**2+AR(2,1)**2
25415       YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1)
25416       VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2)
25417       VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25418       VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2)
25419       VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2)
25420       ZR(1,1) = XML
25421       ZR(1,2) = 0D0
25422       ZR(2,1) = 0D0
25423       ZR(2,2) = XMH
25424       DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1)
25425       XI(1,1) = AR(2,2)/DETX
25426       XI(2,2) = AR(1,1)/DETX
25427       XI(1,2) = -AR(1,2)/DETX
25428       XI(2,1) = -AR(2,1)/DETX
25429       DO 190 I=1,2
25430         DO 180 J=1,2
25431           UMIX(I,J)=0D0
25432           DO 170 K=1,2
25433             DO 160 L=1,2
25434               UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J)
25435   160       CONTINUE
25436   170     CONTINUE
25437   180   CONTINUE
25438   190 CONTINUE
25439
25440       RETURN
25441       END
25442
25443 C*********************************************************************
25444
25445 *$ CREATE PYRNM3.FOR
25446 *COPY PYRNM3
25447 C...PYRNM3
25448 C...Calculates the running of M3, the SU(3) gluino mass parameter.
25449
25450       FUNCTION PYRNM3(RGUT)
25451
25452 C...Double precision and integer declarations.
25453       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25454       INTEGER PYK,PYCHGE,PYCOMP
25455
25456 C...Local variables.
25457       DOUBLE PRECISION PI,R
25458       DOUBLE PRECISION TOL
25459       EXTERNAL PYALPS
25460       DATA TOL/0.001D0/
25461       DATA PI,R/3.141592654D0,0.61803399D0/
25462
25463       C=1D0-R
25464
25465       BX=RGUT*PYALPS(RGUT**2)
25466       AX=MIN(50D0,BX*0.5D0)
25467       CX=MAX(2000D0,2D0*BX)
25468
25469       X0=AX
25470       X3=CX
25471       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
25472         X1=BX
25473         X2=BX+C*(CX-BX)
25474       ELSE
25475         X2=BX
25476         X1=BX-C*(BX-AX)
25477       ENDIF
25478       AS1=PYALPS(X1**2)
25479       F1=ABS(X1-RGUT*AS1)
25480       AS2=PYALPS(X2**2)
25481       F2=ABS(X2-RGUT*AS2)
25482   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
25483         IF(F2.LT.F1) THEN
25484           X0=X1
25485           X1=X2
25486           X2=R*X1+C*X3
25487           F1=F2
25488           AS2=PYALPS(X2**2)
25489           F2=ABS(X2-RGUT*AS2)
25490         ELSE
25491           X3=X2
25492           X2=X1
25493           X1=R*X2+C*X0
25494           F2=F1
25495           AS1=PYALPS(X1**2)
25496           F1=ABS(X1-RGUT*AS1)
25497         ENDIF
25498         GOTO 100
25499       ENDIF
25500       IF(F1.LT.F2) THEN
25501         PYRNM3=X1
25502         XMIN=X1
25503       ELSE
25504         PYRNM3=X2
25505         XMIN=X2
25506       ENDIF
25507
25508       RETURN
25509       END
25510
25511 C*********************************************************************
25512
25513 *$ CREATE PYEIG4.FOR
25514 *COPY PYEIG4
25515 C...PYEIG4
25516 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
25517 C...Specific application: mixing in neutralino sector.
25518
25519       SUBROUTINE PYEIG4(A,W,Z)
25520       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25521       INTEGER PYK,PYCHGE,PYCOMP
25522
25523 C...Arrays: in call and local.
25524       DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
25525
25526 C...Coefficients of fourth-degree equation from matrix.
25527 C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
25528       B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
25529       B2=0D0
25530       DO 110 I=1,3
25531         DO 100 J=I+1,4
25532           B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
25533   100   CONTINUE
25534   110 CONTINUE
25535       B1=0D0
25536       B0=0D0
25537       DO 120 I=1,4
25538         I1=MOD(I,4)+1
25539         I2=MOD(I+1,4)+1
25540         I3=MOD(I+2,4)+1
25541         B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
25542      &  A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
25543      &  A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
25544         B0=B0+(-1D0)**(I+1)*A(1,I)*(
25545      &  A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
25546      &  A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
25547      &  A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
25548   120 CONTINUE
25549
25550 C...Coefficients of third-degree equation needed for
25551 C...separation into two second-degree equations.
25552 C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
25553       C2=-B2
25554       C1=B1*B3-4D0*B0
25555       C0=-B1**2-B0*B3**2+4D0*B0*B2
25556       CQ=C1/3D0-C2**2/9D0
25557       CR=C1*C2/6D0-C0/2D0-C2**3/27D0
25558       CQR=CQ**3+CR**2
25559
25560 C...Cases with one or three real roots.
25561       IF(CQR.GE.0D0) THEN
25562         S1=(CR+SQRT(CQR))**(1D0/3D0)
25563         S2=(CR-SQRT(CQR))**(1D0/3D0)
25564         U=S1+S2-C2/3D0
25565       ELSE
25566         SABS=SQRT(-CQ)
25567         THE=ACOS(CR/SABS**3)/3D0
25568         SRE=SABS*COS(THE)
25569         U=2D0*SRE-C2/3D0
25570       ENDIF
25571
25572 C...Find and solve two second-degree equations.
25573       P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
25574       P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
25575       Q1=U/2D0+SQRT(U**2/4D0-B0)
25576       Q2=U/2D0-SQRT(U**2/4D0-B0)
25577       IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
25578         QSAV=Q1
25579         Q1=Q2
25580         Q2=QSAV
25581       ENDIF
25582       X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
25583       X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
25584       X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
25585       X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
25586
25587 C...Order eigenvalues in asceding mass.
25588       W(1)=X(1)
25589       DO 150 I1=2,4
25590         DO 130 I2=I1-1,1,-1
25591           IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
25592           W(I2+1)=W(I2)
25593   130   CONTINUE
25594   140   W(I2+1)=X(I1)
25595   150 CONTINUE
25596
25597 C...Find equation system for eigenvectors.
25598       DO 250 I=1,4
25599         DO 170 J1=1,4
25600           D(J1,J1)=A(J1,J1)-W(I)
25601           DO 160 J2=J1+1,4
25602             D(J1,J2)=A(J1,J2)
25603             D(J2,J1)=A(J2,J1)
25604   160     CONTINUE
25605   170   CONTINUE
25606
25607 C...Find largest element in matrix.
25608         DAMAX=0D0
25609         DO 190 J1=1,4
25610           DO 180 J2=1,4
25611             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
25612             JA=J1
25613             JB=J2
25614             DAMAX=ABS(D(J1,J2))
25615   180     CONTINUE
25616   190   CONTINUE
25617
25618 C...Subtract others by multiple of row selected above.
25619         DAMAX=0D0
25620         DO 210 J3=JA+1,JA+3
25621           J1=J3-4*((J3-1)/4)
25622           RL=D(J1,JB)/D(JA,JB)
25623           DO 200 J2=1,4
25624             D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
25625             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
25626             JC=J1
25627             JD=J2
25628             DAMAX=ABS(D(J1,J2))
25629   200     CONTINUE
25630   210   CONTINUE
25631
25632 C...Do one more subtraction of a row.
25633         DAMAX=0D0
25634         DO 230 J3=JC+1,JC+3
25635           J1=J3-4*((J3-1)/4)
25636           IF(J1.EQ.JA) GOTO 230
25637           RL=D(J1,JD)/D(JC,JD)
25638           DO 220 J2=1,4
25639             IF(J2.EQ.JB) GOTO 220
25640             D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
25641             IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
25642             JE=J1
25643             DAMAX=ABS(D(J1,J2))
25644   220     CONTINUE
25645   230   CONTINUE
25646
25647 C...Construct unnormalized eigenvector.
25648         JF1=JD+1-4*(JD/4)
25649         JF2=JD+2-4*((JD+1)/4)
25650         IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
25651         IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
25652         E(JF1)=-D(JE,JF2)
25653         E(JF2)=D(JE,JF1)
25654         E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
25655         E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
25656      &  D(JA,JB)
25657
25658 C...Normalize and fill in final array.
25659         EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
25660         SGN=(-1D0)**INT(PYR(0)+0.5D0)
25661         DO 240 J=1,4
25662           Z(I,J)=SGN*E(J)/EA
25663   240   CONTINUE
25664   250 CONTINUE
25665
25666       RETURN
25667       END
25668
25669 C*********************************************************************
25670
25671 *$ CREATE PYHGGM.FOR
25672 *COPY PYHGGM
25673 C...PYHGGM
25674 C...Determines the Higgs boson mass spectrum using several inputs.
25675
25676       SUBROUTINE PYHGGM(ALPHA)
25677
25678 C...Double precision and integer declarations.
25679       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25680       INTEGER PYK,PYCHGE,PYCOMP
25681 C...Parameter statement to help give large particle numbers.
25682       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25683 C...Commonblocks.
25684       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25685       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25686       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25687       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25688       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
25689
25690 C...Local variables.
25691       DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2
25692       DOUBLE PRECISION ALPHA
25693       INTEGER I,J,IHOPT,II,JJ,IT
25694       DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
25695       DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
25696       DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
25697       DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
25698
25699       IHOPT=IMSS(4)
25700       IF(IHOPT.EQ.2) THEN
25701         ALPHA=RMSS(18)
25702         RETURN
25703       ENDIF
25704       AT=RMSS(16)
25705       AB=RMSS(15)
25706       XMU=RMSS(4)
25707       TANB=RMSS(5)
25708
25709       DMA=RMSS(19)
25710       DTANB=TANB
25711       DMQ=RMSS(10)
25712       DMUR=RMSS(12)
25713       DMDR=RMSS(11)
25714       DMTOP=PMAS(6,1)
25715       DMC=PMAS(PYCOMP(KSUSY1+37),1)
25716       DAU=AT
25717       DAD=AB
25718       DMU=XMU
25719
25720       IF(IHOPT.EQ.0) THEN
25721         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25722      &  DMHCH,DSA,DCA,DTANBA)
25723       ELSEIF(IHOPT.EQ.1) THEN
25724         CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
25725      &  DMHCH,DSA,DCA,DTANBA)
25726         CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
25727      &  DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
25728      &  DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA)
25729         DMH=DMHP
25730         DHM=DHMP
25731         DMA=DAMP
25732         IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN
25733          WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
25734          WRITE(MSTU(11),*) ' STOP1 MASSES = ',
25735      & PMAS(PYCOMP(1000006),1),DSTOP2
25736         ENDIF
25737         IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN
25738          WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
25739          WRITE(MSTU(11),*) ' STOP2 MASSES = ',
25740      & PMAS(PYCOMP(2000006),1),DSTOP1
25741         ENDIF
25742         IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN
25743          WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
25744          WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
25745      & PMAS(PYCOMP(1000005),1),DSBOT2
25746         ENDIF
25747         IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN
25748          WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
25749          WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
25750      & PMAS(PYCOMP(2000005),1),DSBOT1
25751         ENDIF
25752
25753       ENDIF
25754
25755       ALPHA=ACOS(DCA)
25756
25757       PMAS(25,1)=DMH
25758       PMAS(35,1)=DHM
25759       PMAS(36,1)=DMA
25760       PMAS(37,1)=DMHCH
25761
25762       RETURN
25763       END
25764
25765 C*********************************************************************
25766
25767 *$ CREATE PYSUBH.FOR
25768 *COPY PYSUBH
25769 C...PYSUBH
25770 C...This routine computes the renormalization group improved
25771 C...values of Higgs masses and couplings in the MSSM.
25772
25773 C...Program based on the work by M. Carena, J.R. Espinosa,
25774 c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
25775
25776 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
25777 C...All masses in GeV units. MA is the CP-odd Higgs mass,
25778 C...MTOP is the physical top mass, MQ and MUR are the soft
25779 C...supersymmetry breaking mass parameters of left handed
25780 C...and right handed stops respectively, AU and AD are the
25781 C...stop and sbottom trilinear soft breaking terms,
25782 C...respectively,  and MU is the supersymmetric
25783 C...Higgs mass parameter. We use the  conventions from
25784 C...the physics report of Haber and Kane: left right
25785 C...stop mixing term proportional to (AU - MU/TANB)
25786 C...We use as input TANB defined at the scale MTOP
25787
25788 C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
25789 C...where MH and HM are the lightest and heaviest CP-even
25790 C...Higgs masses, MHCH is the charged Higgs mass and
25791 C...ALPHA is the Higgs mixing angle
25792 C...TANBA is the angle TANB at the CP-odd Higgs mass scale
25793
25794 C...Range of validity:
25795 C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
25796 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
25797 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
25798 C...are the sbottom  mass eigenvalues, respectively. This
25799 C...range automatically excludes the existence of tachyons.
25800 C...For the charged Higgs mass computation, the method is
25801 C...valid if
25802 C...2 * |MB * AD* TANB|  < M_SUSY**2,  2 * |MTOP * AU| < M_SUSY**2
25803 C...2 * |MB * MU * TANB| < M_SUSY**2,  2 * |MTOP * MU| < M_SUSY**2
25804 C...where M_SUSY**2 is the average of the squared stop mass
25805 C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
25806 C...masses have been assumed to be of order of the stop ones
25807 C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
25808
25809       SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
25810      &XMHCH,SA,CA,TANBA)
25811
25812 C...Double precision and integer declarations.
25813       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25814       INTEGER PYK,PYCHGE,PYCOMP
25815 C...Parameter statement to help give large particle numbers.
25816       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
25817 C...Commonblocks.
25818       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25819       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25820       SAVE /PYDAT1/,/PYDAT2/
25821
25822 C...Local variables.
25823       DOUBLE PRECISION PYALEM,PYALPS
25824       DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
25825       DOUBLE PRECISION XMHCH,SA,CA
25826       DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
25827       DOUBLE PRECISION Q02
25828       DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
25829       DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
25830       DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
25831       DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
25832       DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
25833       DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
25834       DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
25835       DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3
25836
25837       XMZ = PMAS(23,1)
25838       Q02=XMZ**2
25839       AEM=PYALEM(Q02)
25840       ALP1=AEM/(1D0-PARU(102))
25841       ALP2=AEM/PARU(102)
25842       ALPH3Z=PYALPS(Q02)
25843
25844       ALP1 = 0.0101D0
25845       ALP2 = 0.0337D0
25846       ALPH3Z = 0.12D0
25847
25848       V = 174.1D0
25849       PI = PARU(1)
25850       TANBA = TANB
25851       TANBT = TANB
25852
25853 C...MBOTTOM(MTOP) = 3. GEV
25854       XMB = 3D0
25855       ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
25856      &LOG(XMTOP**2/XMZ**2))
25857
25858 C...RMTOP= RUNNING TOP QUARK MASS
25859       RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
25860       XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
25861       T = LOG(XMS**2/XMTOP**2)
25862       SINB = TANB/((1D0 + TANB**2)**0.5D0)
25863       COSB = SINB/TANB
25864 C...IF(MA.LE.XMTOP) TANBA = TANBT
25865       IF(XMA.GT.XMTOP)
25866      &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
25867      &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
25868      &LOG(XMA**2/XMTOP**2))
25869
25870       SINBT = TANBT/SQRT(1D0 + TANBT**2)
25871       COSBT = 1D0/SQRT(1D0 + TANBT**2)
25872       COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
25873       G1 = SQRT(ALP1*4D0*PI)
25874       G2 = SQRT(ALP2*4D0*PI)
25875       G3 = SQRT(ALP3*4D0*PI)
25876       HU = RMTOP/V/SINBT
25877       HD =  XMB/V/COSBT
25878       HU2=HU*HU
25879       HD2=HD*HD
25880       HU4=HU2*HU2
25881       HD4=HD2*HD2
25882       AU2=AU**2
25883       AD2=AD**2
25884       XMS2=XMS**2
25885       XMS3=XMS**3
25886       XMS4=XMS2*XMS2
25887       XMU2=XMU*XMU
25888       PI2=PI*PI
25889
25890       XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
25891       XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
25892       AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
25893      &+ 3D0*(AU + AD)**2/XMS2)/6D0
25894       XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
25895      &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
25896      &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
25897      &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
25898      &-  16D0*G3**2) *T/16D0/PI2)
25899       XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
25900      &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
25901      &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
25902      &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
25903      &-  16D0*G3**2) *T/16D0/PI2)
25904       XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
25905      &(HU2 + HD2)*T/16D0/PI2)
25906      &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25907      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25908      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25909      &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
25910      &-  16D0*G3**2) *T/16D0/PI2)
25911      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25912      &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
25913      &-  16D0*G3**2) *T/16D0/PI2)
25914       XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
25915      &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
25916      &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
25917      &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
25918      &XMS4)*
25919      &(1+ (6D0*HU2 -2D0* HD2
25920      &-  16D0*G3**2) *T/16D0/PI2)
25921      &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
25922      &XMS4)*
25923      &(1+ (6D0*HD2 -2D0* HU2/2D0
25924      &-  16D0*G3**2) *T/16D0/PI2)
25925       XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
25926      &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
25927      &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
25928      &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
25929       XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
25930      &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25931      &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
25932      &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25933       XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
25934      &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25935      &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
25936      &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
25937       TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
25938      &2D0* XLAM6*SINBT*COSBT
25939      &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
25940      &+ XLAM5*COSBT**2)
25941       DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
25942      &XLAM6*COSBT**2
25943      &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
25944      &2D0* XLAM6* COSBT*SINBT
25945      &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25946      &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
25947      &((XLAM1* COSBT**2 +2D0*
25948      &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
25949      &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
25950      &*SINBT**2
25951      &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
25952      &+ XLAM4) + XLAM6*COSBT**2
25953      &+ XLAM7* SINBT**2))
25954
25955       XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
25956       XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
25957       XHM = SQRT(XHM2)
25958       XMH = SQRT(XMH2)
25959       XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
25960       XMHCH = SQRT(XMHCH2)
25961
25962       SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25963      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25964      &XLAM6* COSBT*SINBT
25965      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25966      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25967      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
25968      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
25969
25970       COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
25971      &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
25972      &XMA**2*SINBT*COSBT))/2D0**0.5D0/
25973      &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
25974      &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
25975      &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
25976      &XLAM6* COSBT*SINBT
25977      &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
25978      &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
25979      &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
25980
25981       SA = -SINALP
25982       CA = -COSALP
25983
25984   100 CONTINUE
25985
25986       RETURN
25987       END
25988
25989 C*********************************************************************
25990
25991 *$ CREATE PYPOLE.FOR
25992 *COPY PYPOLE
25993 C...PYPOLE
25994 C...This subroutine computes the CP-even higgs and CP-odd pole
25995 c...Higgs masses and mixing angles.
25996
25997 C...Program based on the work by M. Carena, M. Quiros
25998 C...and C.E.M. Wagner, "Effective potential methods and
25999 C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
26000
26001 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
26002 C...AT,AB,MU
26003 C...where MCHI is the largest chargino mass, MA is the running
26004 C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
26005 C...expectaion values at the scale MTOP, MQ is the third generation
26006 C...left handed squark mass parameter, MUR is the third generation
26007 C...right handed stop mass parameter, MDR is the third generation
26008 C...right handed sbottom mass parameter, MTOP is the pole top quark
26009 C...mass; AT,AB are the soft supersymmetry breaking trilinear
26010 C...couplings of the stop and sbottoms, respectively, and MU is the
26011 C...supersymmetric mass parameter
26012
26013 C...The parameter IHIGGS=0,1,2,3 corresponds to the
26014 c...number of Higgses whose pole mass is computed
26015 c...by the subroutine PYVACU(...). If IHIGGS=0 only running
26016 c...masses are given, what makes the running of the program
26017 c...much faster and it is quite generally a good approximation
26018 c...(for a theoretical discussion see ref. below).
26019 c...If IHIGGS=1, only the pole
26020 c...mass for H is computed. If IHIGGS=2, then h and H, and
26021 c...if IHIGGS=3, then h,H,A polarizations are computed
26022
26023 C...Output: MH and MHP which are the lightest CP-even Higgs running
26024 C...and pole masses, respectively; HM and HMP are the heaviest CP-even
26025 C...Higgs running and pole masses, repectively; SA and CA are the
26026 C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
26027 C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
26028 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
26029 C...the value of TANB at the CP-odd Higgs mass scale
26030
26031 C...This subroutine makes use of CERN library subroutine
26032 C...integration package, which makes the computation of the
26033 C...pole Higgs masses somewhat faster. We thank P. Janot for this
26034 C...improvement. Those who are not able to call the CERN
26035 C...libraries, please use the subroutine SUBHPOLE2.F, which
26036 C...although somewhat slower, gives identical results
26037
26038       SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26039      &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA)
26040
26041 C...Double precision and integer declarations.
26042       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26043       INTEGER PYK,PYCHGE,PYCOMP
26044
26045       CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
26046      &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2,
26047      &SA,CA,STOP1W,STOP2W,TANBA)
26048       SINB = TANB/(TANB**2+1D0)**0.5D0
26049       COSB = 1D0/(TANB**2+1D0)**0.5D0
26050       SINBMA = SINB*CA - COSB*SA
26051
26052       RETURN
26053       END
26054
26055 C*********************************************************************
26056
26057 *$ CREATE PYVACU.FOR
26058 *COPY PYVACU
26059 C...PYVACU
26060 C...Computes Higgs masses and mixing angles, see PYPOLE above.
26061
26062       SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,
26063      &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,
26064      &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA)
26065
26066 C...Double precision and integer declarations.
26067       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26068 C...Parameters.
26069       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26070       INTEGER PYK,PYCHGE,PYCOMP
26071
26072 C...Local variables.
26073       DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
26074      &SSBOT2(2),B(2,2),COUPB(2,2),
26075      &HCOUPT(2,2),HCOUPB(2,2),
26076      &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
26077
26078       DELTA(1,1) = 1D0
26079       DELTA(2,2) = 1D0
26080       DELTA(1,2) = 0D0
26081       DELTA(2,1) = 0D0
26082       V = 174.1D0
26083       XMZ=91.18D0
26084       PI=3.14159D0
26085       ALP3Z=0.12D0
26086       ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ))
26087
26088 C      RXMT = XMT/(1D0+4*ALP3/3D0/PI)
26089       RXMT = PYRNMT(XMT)
26090
26091       HT = RXMT /V
26092       CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
26093      &XMU,XMH,HM,SA,CA,TANBA)
26094       SINB = TANB/(TANB**2+1D0)**0.5D0
26095       COSB = 1D0/(TANB**2+1D0)**0.5D0
26096       COS2B = SINB**2 - COSB**2
26097       SINBPA = SINB*CA + COSB*SA
26098       COSBPA = COSB*CA - SINB*SA
26099       RMBOT = 3D0
26100       XMQ2 = XMQ**2
26101       XMUR2 = XMUR**2
26102       IF(XMUR.LT.0D0) XMUR2=-XMUR2
26103       XMDR2 = XMDR**2
26104       XMST11 = RXMT**2 + XMQ2  - 0.35D0*XMZ**2*COS2B
26105       XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
26106       IF(XMST11.LT.0D0) GOTO 500
26107       IF(XMST22.LT.0D0) GOTO 500
26108       XMSB11 = RMBOT**2 + XMQ2  + 0.42D0*XMZ**2*COS2B
26109       XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
26110       IF(XMSB11.LT.0D0) GOTO 500
26111       IF(XMSB22.LT.0D0) GOTO 500
26112       WMST11 = RXMT**2 + XMQ2
26113       WMST22 = RXMT**2 + XMUR2
26114       XMST12 = RXMT*(AT - XMU/TANB)
26115       XMSB12 = RMBOT*(AB - XMU*TANB)
26116
26117 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26118 C...STOP EIGENVALUES CALCULATION
26119 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26120
26121       STOP12 = 0.5D0*(XMST11+XMST22) +
26122      &0.5D0*((XMST11+XMST22)**2 -
26123      &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
26124       STOP22 = 0.5D0*(XMST11+XMST22) -
26125      &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
26126      &XMST12**2))**0.5D0
26127
26128       IF(STOP22.LT.0D0) GOTO 500
26129       SSTOP2(1) = STOP12
26130       SSTOP2(2) = STOP22
26131       STOP1 = STOP12**0.5D0
26132       STOP2 = STOP22**0.5D0
26133       STOP1W = STOP1
26134       STOP2W = STOP2
26135
26136       IF(XMST12.EQ.0D0) XST11 = 1D0
26137       IF(XMST12.EQ.0D0) XST12 = 0D0
26138       IF(XMST12.EQ.0D0) XST21 = 0D0
26139       IF(XMST12.EQ.0D0) XST22 = 1D0
26140
26141       IF(XMST12.EQ.0D0) GOTO 110
26142
26143   100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26144       XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
26145       XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26146       XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
26147
26148   110 T(1,1) = XST11
26149       T(2,2) = XST22
26150       T(1,2) = XST12
26151       T(2,1) = XST21
26152
26153       SBOT12 = 0.5D0*(XMSB11+XMSB22) +
26154      &0.5D0*((XMSB11+XMSB22)**2 -
26155      &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
26156       SBOT22 = 0.5D0*(XMSB11+XMSB22) -
26157      &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
26158      &XMSB12**2))**0.5D0
26159       IF(SBOT22.LT.0D0) GOTO 500
26160       SBOT1 = SBOT12**0.5D0
26161       SBOT2 = SBOT22**0.5D0
26162
26163       SSBOT2(1) = SBOT12
26164       SSBOT2(2) = SBOT22
26165
26166       IF(XMSB12.EQ.0D0) XSB11 = 1D0
26167       IF(XMSB12.EQ.0D0) XSB12 = 0D0
26168       IF(XMSB12.EQ.0D0) XSB21 = 0D0
26169       IF(XMSB12.EQ.0D0) XSB22 = 1D0
26170
26171       IF(XMSB12.EQ.0D0) GOTO 130
26172
26173   120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26174       XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
26175       XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26176       XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
26177
26178   130 B(1,1) = XSB11
26179       B(2,2) = XSB22
26180       B(1,2) = XSB12
26181       B(2,1) = XSB21
26182
26183
26184       SINT = 0.2320D0
26185       SQR = 2D0**0.5D0
26186       VP = 174.1D0*SQR
26187
26188 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26189 C...STARTING OF LIGHT HIGGS
26190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26191
26192       IF(IHIGGS.EQ.0) GOTO 490
26193
26194       DO 150 I = 1,2
26195         DO 140 J = 1,2
26196           COUPT(I,J) =
26197      &    SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
26198      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26199      &    -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
26200      &    -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
26201      &    T(1,J)*T(2,I))
26202   140   CONTINUE
26203   150 CONTINUE
26204
26205
26206       DO 170 I = 1,2
26207         DO 160 J = 1,2
26208           COUPB(I,J) =
26209      &    -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
26210      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26211      &    +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
26212      &    +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
26213      &    B(1,J)*B(2,I))
26214   160   CONTINUE
26215   170 CONTINUE
26216
26217       PRUN = XMH
26218       EPS = 1D-4*PRUN
26219       ITER = 0
26220   180 ITER = ITER + 1
26221       DO 230  I3 = 1,3
26222
26223         PR(I3)=PRUN+(I3-2)*EPS/2
26224         P2=PR(I3)**2
26225         POLT = 0D0
26226         DO 200 I = 1,2
26227           DO 190 J = 1,2
26228             POLT = POLT + COUPT(I,J)**2*3D0*
26229      &      PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26230   190     CONTINUE
26231   200   CONTINUE
26232         POLB = 0D0
26233         DO 220 I = 1,2
26234           DO 210 J = 1,2
26235             POLB = POLB + COUPB(I,J)**2*3D0*
26236      &      PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26237   210     CONTINUE
26238   220   CONTINUE
26239         RXMT2 = RXMT**2
26240         XMT2=XMT**2
26241
26242         POLTT =
26243      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
26244      &  CA**2/SINB**2 *
26245      &  (-2D0*XMT**2+0.5D0*P2)*
26246      &  PYFINT(P2,XMT2,XMT2)
26247
26248         POL = POLT + POLB + POLTT
26249         POLAR(I3) = P2 - XMH**2 - POL
26250   230 CONTINUE
26251       DERIV = (POLAR(3)-POLAR(1))/EPS
26252       DRUN = - POLAR(2)/DERIV
26253       PRUN = PRUN + DRUN
26254       P2 = PRUN**2
26255       IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240
26256       GOTO 180
26257   240 CONTINUE
26258
26259       XMHP = P2**0.5D0
26260
26261 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26262 C...END OF LIGHT HIGGS
26263 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26264
26265   250 IF(IHIGGS.EQ.1) GOTO 490
26266
26267 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26268 C... STARTING OF HEAVY HIGGS
26269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26270
26271       DO 270 I = 1,2
26272         DO 260 J = 1,2
26273           HCOUPT(I,J) =
26274      &    -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
26275      &    (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
26276      &    -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
26277      &    -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
26278      &    T(1,J)*T(2,I))
26279   260   CONTINUE
26280   270 CONTINUE
26281
26282       DO 290 I = 1,2
26283         DO 280 J = 1,2
26284           HCOUPB(I,J) =
26285      &    SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
26286      &    (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
26287      &    -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
26288      &    -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
26289      &    B(1,J)*B(2,I))
26290           HCOUPB(I,J)=0D0
26291   280   CONTINUE
26292   290 CONTINUE
26293
26294       PRUN = HM
26295       EPS = 1D-4*PRUN
26296       ITER = 0
26297   300 ITER = ITER + 1
26298       DO 350 I3 = 1,3
26299         PR(I3)=PRUN+(I3-2)*EPS/2
26300         HP2=PR(I3)**2
26301
26302         HPOLT = 0D0
26303         DO 320 I = 1,2
26304           DO 310 J = 1,2
26305             HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
26306      &      PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26307   310     CONTINUE
26308   320   CONTINUE
26309
26310         HPOLB = 0D0
26311         DO 340 I = 1,2
26312           DO 330 J = 1,2
26313             HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
26314      &      PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26315   330     CONTINUE
26316   340   CONTINUE
26317
26318         RXMT2 = RXMT**2
26319         XMT2  = XMT**2
26320
26321         HPOLTT =
26322      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
26323      &  SA**2/SINB**2 *
26324      &  (-2D0*XMT**2+0.5D0*HP2)*
26325      &  PYFINT(HP2,XMT2,XMT2)
26326
26327         HPOL = HPOLT + HPOLB + HPOLTT
26328         POLAR(I3) =HP2-HM**2-HPOL
26329   350 CONTINUE
26330       DERIV = (POLAR(3)-POLAR(1))/EPS
26331       DRUN = - POLAR(2)/DERIV
26332       PRUN = PRUN + DRUN
26333       HP2 = PRUN**2
26334       IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360
26335       GOTO 300
26336   360 CONTINUE
26337
26338
26339   370 CONTINUE
26340       HMP = HP2**0.5D0
26341
26342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26343 C... END OF HEAVY HIGGS
26344 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26345
26346       IF(IHIGGS.EQ.2) GOTO 490
26347
26348 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26349 C...BEGINNING OF PSEUDOSCALAR HIGGS
26350 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26351
26352       DO 390 I = 1,2
26353         DO 380 J = 1,2
26354           ACOUPT(I,J) =
26355      &    -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
26356      &    (T(1,I)*T(2,J) -T(1,J)*T(2,I))
26357   380   CONTINUE
26358   390 CONTINUE
26359       DO 410 I = 1,2
26360         DO 400 J = 1,2
26361           ACOUPB(I,J) =
26362      &    RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
26363      &    (B(1,I)*B(2,J) -B(1,J)*B(2,I))
26364   400   CONTINUE
26365   410 CONTINUE
26366
26367       PRUN = XMA
26368       EPS = 1D-4*PRUN
26369       ITER = 0
26370   420 ITER = ITER + 1
26371       DO 470 I3 = 1,3
26372         PR(I3)=PRUN+(I3-2)*EPS/2
26373         AP2=PR(I3)**2
26374         APOLT = 0D0
26375         DO 440 I = 1,2
26376           DO 430 J = 1,2
26377             APOLT = APOLT + ACOUPT(I,J)**2*3D0*
26378      &      PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
26379   430     CONTINUE
26380   440   CONTINUE
26381         APOLB = 0D0
26382         DO 460 I = 1,2
26383           DO 450 J = 1,2
26384             APOLB = APOLB + ACOUPB(I,J)**2*3D0*
26385      &      PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
26386   450     CONTINUE
26387   460   CONTINUE
26388         RXMT2 = RXMT**2
26389         XMT2=XMT**2
26390         APOLTT =
26391      &  3D0*RXMT**2/8D0/PI**2/  V  **2*
26392      &  COSB**2/SINB**2 *
26393      &  (-0.5D0*AP2)*
26394      &  PYFINT(AP2,XMT2,XMT2)
26395         APOL = APOLT + APOLB + APOLTT
26396         POLAR(I3) = AP2 - XMA**2 -APOL
26397   470 CONTINUE
26398       DERIV = (POLAR(3)-POLAR(1))/EPS
26399       DRUN = - POLAR(2)/DERIV
26400       PRUN = PRUN + DRUN
26401       AP2 = PRUN**2
26402       IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480
26403       GOTO 420
26404   480 CONTINUE
26405
26406       AMP = AP2**0.5D0
26407
26408 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26409 C...END OF PSEUDOSCALAR HIGGS
26410 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26411
26412       IF(IHIGGS.EQ.3) GOTO 490
26413
26414   490 CONTINUE
26415       RETURN
26416   500 CONTINUE
26417       WRITE(MSTU(11),*) ' EXITING IN PYVACU '
26418       WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
26419       WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
26420       WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
26421       STOP
26422       END
26423
26424 C*********************************************************************
26425
26426 *$ CREATE PYRGHM.FOR
26427 *COPY PYRGHM
26428 C...PYRGHM
26429 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26430
26431       SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,
26432      &XMHP,HMP,SA,CA,TANBA)
26433
26434 C...Double precision and integer declarations.
26435       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26436       INTEGER PYK,PYCHGE,PYCOMP
26437
26438 C...Local variables.
26439       DIMENSION VH(2,2),XM2(2,2),XM2P(2,2)
26440
26441       XMZ = 91.18D0
26442       ALP1 = 0.0101D0
26443       ALP2 = 0.0337D0
26444       ALP3Z = 0.12D0
26445       V = 174.1D0
26446       PI = 3.14159D0
26447       TANBA = TANB
26448       TANBT = TANB
26449
26450 C...MBOTTOM(XMT) = 3. GEV
26451       XMB = 3D0
26452       ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z*
26453      &LOG(XMT**2/XMZ**2))
26454
26455 C...RXMT= RUNNING TOP QUARK MASS
26456       RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26457       TQ = LOG((XMQ**2+XMT**2)/XMT**2)
26458       TU = LOG((XMUR**2 + XMT**2)/XMT**2)
26459       TD = LOG((XMDL**2 + XMT**2)/XMT**2)
26460       SINB = TANB/((1D0 + TANB**2)**0.5D0)
26461       COSB = SINB/TANB
26462       IF(XMA.GT.XMT)
26463      &TANBA = TANB*(1D0-3D0/32D0/PI**2*
26464      &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
26465      &LOG(XMA**2/XMT**2))
26466       IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA
26467       SINB = TANBT/((1D0 + TANBT**2)**0.5D0)
26468       COSB = 1D0/((1D0 + TANBT**2)**0.5D0)
26469       COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
26470       G1 = (ALP1*4D0*PI)**0.5D0
26471       G2 = (ALP2*4D0*PI)**0.5D0
26472       G3 = (ALP3*4D0*PI)**0.5D0
26473       HU = RXMT/V/SINB
26474       HD =  XMB/V/COSB
26475
26476       CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD,
26477      &XMU,VH,STOP1,STOP2)
26478
26479       IF(XMQ.GT.XMUR) TP = TQ - TU
26480       IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ
26481       IF(XMQ.GT.XMUR) TDP = TU
26482       IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ
26483       IF(XMQ.GT.XMDL) TPD = TQ - TD
26484       IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ
26485       IF(XMQ.GT.XMDL) TDPD = TD
26486       IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ
26487
26488       IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
26489       IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2*
26490      &HD**2*(G1**2/3D0+G2**2)*TPD
26491
26492       IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP
26493       IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2*
26494      &HU**2*(-G1**2/3D0+G2**2)*TP
26495
26496       DLAM3 = 0D0
26497       DLAM4 = 0D0
26498
26499       IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
26500       IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2*
26501      &(G2**2-G1**2/3D0)*TPD
26502
26503       IF(XMQ.GT.XMUR) DLAM3 = DLAM3 -
26504      &1D0/16D0/PI**2*G1**2*HU**2*TP
26505       IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 +
26506      &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
26507
26508       IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
26509       IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2*
26510      &HD**2*TPD
26511
26512       XLAM1 = ((G1**2 + G2**2)/4D0)*
26513      &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
26514      &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0
26515      &+ (3D0*HD**2/2D0 + HU**2/2D0
26516      &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
26517      &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0  + (3D0*HD**2/2D0 + HU**2/2D0
26518      &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1
26519       XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
26520      &(TP + TDP)/8D0/PI**2)
26521      &+(3D0*HU**4/16D0/PI**2) *TP*(1D0
26522      &+ (3D0*HU**2/2D0 + HD**2/2D0
26523      &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
26524      &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
26525      &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2
26526       XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
26527      &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
26528      &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3
26529       XLAM4 = (- G2**2/2D0)*(1D0
26530      &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
26531      &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4
26532
26533       XLAM5 = 0D0
26534       XLAM6 = 0D0
26535       XLAM7 = 0D0
26536
26537       XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6*
26538      &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2
26539
26540       XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7*
26541      &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2
26542       XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)*
26543      &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB
26544
26545       XM2(2,1) = XM2(1,2)
26546
26547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26548 C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
26549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26550
26551       XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0
26552
26553       IF(XMC.GT.XMSSU) GOTO 100
26554       IF(XMC.LT.XMT) XMC=XMT
26555
26556       TCHAR=LOG(XMSSU**2/XMC**2)
26557
26558       DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
26559       DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
26560      &+4D0/32/PI**2*G1**2*G2**2)*TCHAR
26561
26562       DEM112=2D0*DEL12*V**2*COSB**2
26563       DEM222=2D0*DEL12*V**2*SINB**2
26564       DEM122=2D0*DEL3P4*V**2*SINB*COSB
26565
26566       XM2(1,1)=XM2(1,1)+DEM112
26567       XM2(2,2)=XM2(2,2)+DEM222
26568       XM2(1,2)=XM2(1,2)+DEM122
26569       XM2(2,1)=XM2(2,1)+DEM122
26570
26571   100 CONTINUE
26572
26573 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26574 C...END OF CHARGINOS/NEUTRALINOS
26575 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26576
26577       DO 120 I = 1,2
26578         DO 110 J = 1,2
26579           XM2P(I,J) = XM2(I,J) + VH(I,J)
26580   110   CONTINUE
26581   120 CONTINUE
26582
26583       TRM2P = XM2P(1,1) + XM2P(2,2)
26584       DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1)
26585
26586       XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26587       HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0
26588       HMP = HM2P**0.5D0
26589       IF(XMH2P.LT.0D0) GOTO 130
26590       XMHP = XMH2P**0.5D0
26591       S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0
26592       C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0
26593       IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0
26594       IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0
26595       SA = SIN(ALP)
26596       CA = COS(ALP)
26597       SQBMA = (SINB*CA - COSB*SA)**2
26598   130 XIN = 1D0
26599   140 CONTINUE
26600
26601       RETURN
26602       END
26603
26604 C*********************************************************************
26605
26606 *$ CREATE PYGFXX.FOR
26607 *COPY PYGFXX
26608 C...PYGFXX
26609 C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.
26610
26611       SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,
26612      &STOP1,STOP2)
26613
26614 C...Double precision and integer declarations.
26615       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26616       INTEGER PYK,PYCHGE,PYCOMP
26617
26618 C...Local variables.
26619       DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2),
26620      &VH3T(2,2),VH3B(2,2),
26621      &HMIX(2,2),AL(2,2),XM2(2,2)
26622
26623 C...Statement function.
26624       G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y)
26625
26626       IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
26627       XMQ2 = XMQ**2
26628       XMUR2 = XMUR**2
26629       XMDL2 = XMDL**2
26630       TANBA = TANB
26631       SINBA = TANBA/(TANBA**2+1D0)**0.5D0
26632       COSBA = SINBA/TANBA
26633
26634       SINB = TANB/(TANB**2+1D0)**0.5D0
26635       COSB = SINB/TANB
26636       PI = 3.14159D0
26637       G2 = (0.0336D0*4D0*PI)**0.5D0
26638       G12 = (0.0101D0*4D0*PI)
26639       G1 = G12**0.5D0
26640       XMZ = 91.18D0
26641       V = 174.1D0
26642       MW = (G2**2*V**2/2D0)**0.5D0
26643       ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2))
26644
26645       XMB = 3D0
26646       IF(XMQ.GT.XMUR) XMST = XMQ
26647       IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR
26648
26649       XMSUT = (XMST**2  + XMT**2)**0.5D0
26650
26651       IF(XMQ.GT.XMDL) XMSB = XMQ
26652       IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL
26653
26654       XMSUB = (XMSB**2 + XMB**2)**0.5D0
26655
26656       TT = LOG(XMSUT**2/XMT**2)
26657       TB = LOG(XMSUB**2/XMT**2)
26658
26659       RXMT = XMT/(1D0+4D0*ALP3/3D0/PI)
26660       HT = RXMT/(174.1D0*SINB)
26661       HTST = RXMT/174.1D0
26662       HB = XMB/174.1D0/COSB
26663       G32 = ALP3*4D0*PI
26664       BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
26665       BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
26666       AL2 = 3D0/8D0/PI**2*HT**2
26667       BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2
26668       ALST = 3D0/8D0/PI**2*HTST**2
26669       AL1 = 3D0/8D0/PI**2*HB**2
26670
26671       AL(1,1) = AL1
26672       AL(1,2) = (AL2+AL1)/2D0
26673       AL(2,1) = (AL2+AL1)/2D0
26674       AL(2,2) = AL2
26675
26676       XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT)
26677       XMT2 = SQRT(XMT4)
26678       XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB)
26679       XMBOT2 = SQRT(XMBOT4)
26680
26681       IF(XMA.GT.XMT) THEN
26682         VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2*
26683      &  LOG(XMT**2/XMA**2))
26684         H1I = VI* COSBA
26685         H2I = VI*SINBA
26686         H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0
26687         H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0
26688         H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0
26689         H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0
26690       ELSE
26691         VI = 174.1D0
26692         H1I = VI*COSB
26693         H2I = VI*SINB
26694         H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0
26695         H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0
26696         H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0
26697         H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0
26698       ENDIF
26699
26700       TANBST = H2T/H1T
26701       SINBT = TANBST/(1D0+TANBST**2)**0.5D0
26702       COSBT = SINBT/TANBST
26703
26704       TANBSB = H2B/H1B
26705       SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0
26706       COSBB = SINBB/TANBSB
26707
26708       STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26709      &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26710      &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26711      &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0
26712       STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2
26713      &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
26714      &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
26715      &XMQ2 - XMUR2)**2*0.25D0
26716      &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0
26717       IF(STOP22.LT.0D0) GOTO 120
26718       SBOT12 = (XMQ2 + XMDL2)*0.5D0
26719      &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26720      &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26721      &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26722       SBOT22 = (XMQ2 + XMDL2)*0.5D0
26723      &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
26724      &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
26725      &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0
26726       IF(SBOT22.LT.0D0) GOTO 120
26727
26728       STOP1 = STOP12**0.5D0
26729       STOP2 = STOP22**0.5D0
26730       SBOT1 = SBOT12**0.5D0
26731       SBOT2 = SBOT22**0.5D0
26732
26733       VH1(1,1) = 1D0/TANBST
26734       VH1(2,1) = -1D0
26735       VH1(1,2) = -1D0
26736       VH1(2,2) = TANBST
26737       VH2(1,1) = TANBST
26738       VH2(1,2) = -1D0
26739       VH2(2,1) = -1D0
26740       VH2(2,2) = 1D0/TANBST
26741
26742 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26743 C...D-TERMS
26744 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
26745       STW=0.2320D0
26746
26747       F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)*
26748      &LOG(STOP1/STOP2)
26749      &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2))
26750      &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2))
26751
26752       F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)*
26753      &LOG(SBOT1/SBOT2)
26754      &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2))
26755      &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2))
26756
26757       F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)*
26758      &(-0.5D0*LOG(STOP12/STOP22)
26759      &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)*
26760      &G(STOP12,STOP22))
26761
26762       F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
26763      &(0.5D0*LOG(SBOT12/SBOT22)
26764      &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)*
26765      &G(SBOT12,SBOT22))
26766
26767       VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
26768      &(XMQ2+XMBOT2)/(XMDL2+XMBOT2))
26769      &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
26770      &LOG(SBOT1**2/SBOT2**2)) +
26771      &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
26772      &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
26773
26774       VH3T(1,1) =
26775      &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
26776      &-STOP2**2))**2*G(STOP12,STOP22)
26777
26778       VH3B(1,1)=VH3B(1,1)+
26779      &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B)
26780
26781       VH3T(1,1) = VH3T(1,1) +
26782      &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T)
26783
26784       VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
26785      &(XMQ2+XMT2)/(XMUR2+XMT2))
26786      &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
26787      &LOG(STOP1**2/STOP2**2)) +
26788      &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
26789      &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
26790
26791       VH3B(2,2) =
26792      &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
26793      &-SBOT2**2))**2*G(SBOT12,SBOT22)
26794
26795       VH3T(2,2)=VH3T(2,2)+
26796      &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T)
26797
26798       VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B
26799
26800       VH3T(1,2) = -
26801      &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
26802      &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
26803      &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
26804
26805       VH3B(1,2) =
26806      &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/
26807      &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
26808      &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
26809
26810       VH3T(1,2)=VH3T(1,2) +
26811      &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T)
26812
26813       VH3B(1,2)=VH3B(1,2)
26814      &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B)
26815
26816       VH3T(2,1) = VH3T(1,2)
26817       VH3B(2,1) = VH3B(1,2)
26818
26819       TQ = LOG((XMQ2 + XMT2)/XMT2)
26820       TU = LOG((XMUR2+XMT2)/XMT2)
26821       TQD = LOG((XMQ2 + XMB**2)/XMB**2)
26822       TD = LOG((XMDL2+XMB**2)/XMB**2)
26823
26824       DO 110 I = 1,2
26825         DO 100 J = 1,2
26826
26827           VH(I,J) =
26828      &    6D0/(8D0*PI**2*(H1T**2+H2T**2))
26829      &    *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
26830      &    6D0/(8D0*PI**2*(H1B**2+H2B**2))
26831      &    *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
26832
26833   100   CONTINUE
26834   110 CONTINUE
26835
26836       GOTO 150
26837   120 DO 140 I =1,2
26838         DO 130 J = 1,2
26839           VH(I,J) = -1D+15
26840   130   CONTINUE
26841   140 CONTINUE
26842
26843   150 CONTINUE
26844
26845       RETURN
26846       END
26847
26848 C*********************************************************************
26849
26850 *$ CREATE PYFINT.FOR
26851 *COPY PYFINT
26852 C...PYFINT
26853 C...Auxiliary routine to PYVACU for SUSY Higgs calculations.
26854
26855       FUNCTION PYFINT(A,B,C)
26856
26857 C...Double precision and integer declarations.
26858       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26859       INTEGER PYK,PYCHGE,PYCOMP
26860 C...Commonblock.
26861       COMMON/PYINTS/XXM(20)
26862       SAVE/PYINTS/
26863
26864 C...Local variables.
26865       EXTERNAL PYFISB
26866
26867       XXM(1)=A
26868       XXM(2)=B
26869       XXM(3)=C
26870       XLO=0D0
26871       XHI=1D0
26872       PYFINT  = PYGAUS(PYFISB,XLO,XHI,1D-3)
26873
26874       RETURN
26875       END
26876
26877 C*********************************************************************
26878
26879 *$ CREATE PYFISB.FOR
26880 *COPY PYFISB
26881 C...PYFISB
26882 C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
26883
26884       FUNCTION PYFISB(X)
26885
26886 C...Double precision and integer declarations.
26887       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26888       INTEGER PYK,PYCHGE,PYCOMP
26889 C...Commonblock.
26890       COMMON/PYINTS/XXM(20)
26891       SAVE/PYINTS/
26892
26893       PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
26894      &(X*(XXM(2)-XXM(3))+XXM(3)))
26895
26896       RETURN
26897       END
26898
26899 C*********************************************************************
26900
26901 *$ CREATE PYSFDC.FOR
26902 *COPY PYSFDC
26903 C...PYSFDC
26904 C...Calculates decays of sfermions.
26905
26906       SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
26907
26908 C...Double precision and integer declarations.
26909       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26910       INTEGER PYK,PYCHGE,PYCOMP
26911 C...Parameter statement to help give large particle numbers.
26912       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
26913 C...Commonblocks.
26914       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26915       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26916       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
26917       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
26918      &SFMIX(16,4)
26919       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
26920
26921 C...Local variables.
26922       INTEGER KFIN,KCIN
26923       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,
26924      &XMZ2,AXMJ,AXMI
26925       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
26926       DOUBLE PRECISION PYLAMF,XL
26927       DOUBLE PRECISION TANW,XW,AEM,C1,AS
26928       DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP
26929       DOUBLE PRECISION CH1,CH2,CH3,CH4
26930       DOUBLE PRECISION XMBOT,XMTOP
26931       DOUBLE PRECISION XLAM(0:200)
26932       INTEGER IDLAM(200,3)
26933       INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II
26934       DOUBLE PRECISION SR2
26935       DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
26936       DOUBLE PRECISION CW
26937       DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
26938       DOUBLE PRECISION COSA,SINA,TANB
26939       DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT
26940       DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR
26941       INTEGER IG,KF1,KF2,ILR2,IDP
26942       INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
26943       DATA IGG/23,25,35,36/
26944       DATA PI/3.141592654D0/
26945       DATA SR2/1.4142136D0/
26946       DATA KFNCHI/1000022,1000023,1000025,1000035/
26947       DATA KFCCHI/1000024,1000037/
26948
26949 C...COUNT THE NUMBER OF DECAY MODES
26950       LKNT=0
26951
26952 C...NO NU_R DECAYS
26953       IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
26954      &KFIN.EQ.KSUSY2+16) RETURN
26955
26956       XMW=PMAS(24,1)
26957       XMW2=XMW**2
26958       XMZ=PMAS(23,1)
26959       XMZ2=XMZ**2
26960       XW=PARU(102)
26961       TANW = SQRT(XW/(1D0-XW))
26962       CW=SQRT(1D0-XW)
26963
26964 C...KCIN
26965       KCIN=PYCOMP(KFIN)
26966 C...ILR is 1 for left and 2 for right.
26967       ILR=KFIN/KSUSY1
26968 C...IFL is matching non-SUSY flavour.
26969       IFL=MOD(KFIN,KSUSY1)
26970 C...IDU is weak isospin, 1 for down and 2 for up.
26971       IDU=2-MOD(IFL,2)
26972
26973       XMI=PMAS(KCIN,1)
26974       XMI2=XMI**2
26975       AEM=PYALEM(XMI2)
26976       AS =PYALPS(XMI2)
26977       C1=AEM/XW
26978       XMI3=XMI**3
26979       EI=KCHG(IFL,1)/3D0
26980
26981       XMBOT=3D0
26982       XMTOP=PYRNMT(PMAS(6,1))
26983       XMBOT=0D0
26984
26985       TANB=RMSS(5)
26986       BETA=ATAN(TANB)
26987       ALFA=RMSS(18)
26988       CBETA=COS(BETA)
26989       SBETA=TANB*CBETA
26990       SINA=SIN(ALFA)
26991       COSA=COS(ALFA)
26992       XMU=-RMSS(4)
26993       ATRIT=RMSS(16)
26994       ATRIB=RMSS(15)
26995       ATRIL=RMSS(17)
26996
26997 C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
26998
26999       IF(IMSS(11).EQ.1) THEN
27000         XMP=RMSS(28)
27001         IDG=39+KSUSY1
27002         XMGR=PMAS(PYCOMP(IDG),1)
27003         XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27004         IF(IFL.EQ.5) THEN
27005           XMF=XMBOT
27006         ELSEIF(IFL.EQ.6) THEN
27007           XMF=XMTOP
27008         ELSE
27009           XMF=PMAS(IFL,1)
27010         ENDIF
27011         IF(XMI.GT.XMGR+XMF) THEN
27012           LKNT=LKNT+1
27013           IDLAM(LKNT,1)=IDG
27014           IDLAM(LKNT,2)=IFL
27015           IDLAM(LKNT,3)=0
27016           XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
27017         ENDIF
27018       ENDIF
27019
27020 C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
27021
27022 C...CHARGED DECAYS:
27023       DO 100 IX=1,2
27024 C...DI -> U CHI1-,CHI2-
27025         IF(IDU.EQ.1) THEN
27026           XMFP=PMAS(IFL+1,1)
27027           XMF =PMAS(IFL,1)
27028 C...UI -> D CHI1+,CHI2+
27029         ELSE
27030           XMFP=PMAS(IFL-1,1)
27031           XMF =PMAS(IFL,1)
27032         ENDIF
27033         XMJ=SMW(IX)
27034         AXMJ=ABS(XMJ)
27035         IF(XMI.GE.AXMJ+XMFP) THEN
27036           XMA2=XMJ**2
27037           XMB2=XMFP**2
27038           IF(IDU.EQ.2) THEN
27039             IF(IFL.EQ.6) THEN
27040               XMFP=XMBOT
27041               XMF =XMTOP
27042             ELSEIF(IFL.LT.6) THEN
27043               XMF=0D0
27044               XMFP=0D0
27045             ENDIF
27046             BL=VMIX(IX,1)
27047             AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA
27048             BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA
27049             AR=0D0
27050           ELSE
27051             IF(IFL.EQ.5) THEN
27052               XMF =XMBOT
27053               XMFP=XMTOP
27054             ELSEIF(IFL.LT.5) THEN
27055               XMF=0D0
27056               XMFP=0D0
27057             ENDIF
27058             BL=UMIX(IX,1)
27059             AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA
27060             BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA
27061             AR=0D0
27062           ENDIF
27063
27064           ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27065           BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27066           ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27067           BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27068           AL=ALP
27069           BL=BLP
27070           AR=ARP
27071           BR=BRP
27072
27073 C...F1 -> F` CHI
27074           IF(ILR.EQ.1) THEN
27075             CA=AL
27076             CB=BL
27077 C...F2 -> F` CHI
27078           ELSE
27079             CA=AR
27080             CB=BR
27081           ENDIF
27082           LKNT=LKNT+1
27083           XL=PYLAMF(XMI2,XMA2,XMB2)
27084 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27085           XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27086      &    (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP)
27087           IDLAM(LKNT,3)=0
27088           IF(IDU.EQ.1) THEN
27089             IDLAM(LKNT,1)=-KFCCHI(IX)
27090             IDLAM(LKNT,2)=IFL+1
27091           ELSE
27092             IDLAM(LKNT,1)=KFCCHI(IX)
27093             IDLAM(LKNT,2)=IFL-1
27094           ENDIF
27095         ENDIF
27096   100 CONTINUE
27097
27098 C...NEUTRAL DECAYS
27099       DO 110 IX=1,4
27100 C...DI -> D CHI10
27101         XMF=PMAS(IFL,1)
27102         XMJ=SMZ(IX)
27103         AXMJ=ABS(XMJ)
27104         IF(XMI.GE.AXMJ+XMF) THEN
27105           XMA2=XMJ**2
27106           XMB2=XMF**2
27107           IF(IDU.EQ.1) THEN
27108             IF(IFL.EQ.5) THEN
27109               XMF=XMBOT
27110             ELSEIF(IFL.LT.5) THEN
27111               XMF=0D0
27112             ENDIF
27113             BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1)
27114             AL=XMF*ZMIX(IX,3)/XMW/CBETA
27115             AR=-2D0*EI*TANW*ZMIX(IX,1)
27116             BR=AL
27117           ELSE
27118             IF(IFL.EQ.6) THEN
27119               XMF=XMTOP
27120             ELSEIF(IFL.LT.5) THEN
27121               XMF=0D0
27122             ENDIF
27123             BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1)
27124             AL=XMF*ZMIX(IX,4)/XMW/SBETA
27125             AR=-2D0*EI*TANW*ZMIX(IX,1)
27126             BR=AL
27127           ENDIF
27128
27129           ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR
27130           BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR
27131           ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL
27132           BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL
27133           AL=ALP
27134           BL=BLP
27135           AR=ARP
27136           BR=BRP
27137
27138 C...F1 -> F CHI
27139           IF(ILR.EQ.1) THEN
27140             CA=AL
27141             CB=BL
27142 C...F2 -> F CHI
27143           ELSE
27144             CA=AR
27145             CB=BR
27146           ENDIF
27147           LKNT=LKNT+1
27148           XL=PYLAMF(XMI2,XMA2,XMB2)
27149 C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
27150           XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27151      &    (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27152           IDLAM(LKNT,1)=KFNCHI(IX)
27153           IDLAM(LKNT,2)=IFL
27154           IDLAM(LKNT,3)=0
27155         ENDIF
27156   110 CONTINUE
27157
27158 C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
27159 C...IG=23,25,35,36
27160       DO 120 II=1,4
27161         IG=IGG(II)
27162         IF(ILR.EQ.1) GOTO 120
27163         XMB=PMAS(IG,1)
27164         XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
27165         IF(XMI.LT.XMSF1+XMB) GOTO 120
27166         IF(IG.EQ.23) THEN
27167           BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
27168           BR=EI*XW/CW
27169           BLR=0D0
27170         ELSEIF(IG.EQ.25) THEN
27171           IF(IFL.EQ.5) THEN
27172             XMF=XMBOT
27173           ELSEIF(IFL.EQ.6) THEN
27174             XMF=XMTOP
27175           ELSEIF(IFL.LT.5) THEN
27176             XMF=0D0
27177           ELSE
27178             XMF=PMAS(IFL,1)
27179           ENDIF
27180           IF(IDU.EQ.2) THEN
27181             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27182      &      XMF**2/XMW*COSA/SBETA
27183             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27184      &      XMF**2/XMW*COSA/SBETA
27185           ELSE
27186             GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
27187      &      XMF**2/XMW*(-SINA)/CBETA
27188             GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
27189      &      XMF**2/XMW*(-SINA)/CBETA
27190           ENDIF
27191           IF(IFL.EQ.5) THEN
27192             AT=ATRIB
27193           ELSEIF(IFL.EQ.6) THEN
27194             AT=ATRIT
27195           ELSEIF(IFL.EQ.15) THEN
27196             AT=ATRIL
27197           ELSE
27198             AT=0D0
27199           ENDIF
27200           IF(IDU.EQ.2) THEN
27201             GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
27202      &      AT*COSA)
27203           ELSE
27204             GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
27205      &      AT*SINA)
27206           ENDIF
27207           BL=GHLL
27208           BR=GHRR
27209           BLR=-GHLR
27210         ELSEIF(IG.EQ.35) THEN
27211           IF(IFL.EQ.5) THEN
27212             XMF=XMBOT
27213           ELSEIF(IFL.EQ.6) THEN
27214             XMF=XMTOP
27215           ELSEIF(IFL.LT.5) THEN
27216             XMF=0D0
27217           ELSE
27218             XMF=PMAS(IFL,1)
27219           ENDIF
27220           IF(IDU.EQ.2) THEN
27221             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27222      &      XMF**2/XMW*SINA/SBETA
27223             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27224      &      XMF**2/XMW*SINA/SBETA
27225           ELSE
27226             GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
27227      &      XMF**2/XMW*COSA/CBETA
27228             GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
27229      &      XMF**2/XMW*COSA/CBETA
27230           ENDIF
27231           IF(IFL.EQ.5) THEN
27232             AT=ATRIB
27233           ELSEIF(IFL.EQ.6) THEN
27234             AT=ATRIT
27235           ELSEIF(IFL.EQ.15) THEN
27236             AT=ATRIL
27237           ELSE
27238             AT=0D0
27239           ENDIF
27240           IF(IDU.EQ.2) THEN
27241             GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
27242      &      AT*SINA)
27243           ELSE
27244             GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
27245      &      AT*COSA)
27246           ENDIF
27247           BL=GHLL
27248           BR=GHRR
27249           BLR=GHLR
27250         ELSEIF(IG.EQ.36) THEN
27251           GHLL=0D0
27252           GHRR=0D0
27253           IF(IFL.EQ.5) THEN
27254             XMF=XMBOT
27255           ELSEIF(IFL.EQ.6) THEN
27256             XMF=XMTOP
27257           ELSEIF(IFL.LT.5) THEN
27258             XMF=0D0
27259           ELSE
27260             XMF=PMAS(IFL,1)
27261           ENDIF
27262           IF(IFL.EQ.5) THEN
27263             AT=ATRIB
27264           ELSEIF(IFL.EQ.6) THEN
27265             AT=ATRIT
27266           ELSEIF(IFL.EQ.15) THEN
27267             AT=ATRIL
27268           ELSE
27269             AT=0D0
27270           ENDIF
27271           IF(IDU.EQ.2) THEN
27272             GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
27273           ELSE
27274             GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
27275           ENDIF
27276           BL=GHLL
27277           BR=GHRR
27278           BLR=GHLR
27279         ENDIF
27280         AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
27281      &  SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
27282      &  (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
27283         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27284         LKNT=LKNT+1
27285         IF(IG.EQ.23) THEN
27286           XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27287         ELSE
27288           XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
27289         ENDIF
27290         IDLAM(LKNT,3)=0
27291         IDLAM(LKNT,1)=KFIN-KSUSY1
27292         IDLAM(LKNT,2)=IG
27293   120 CONTINUE
27294
27295 C...SF -> SF' + W
27296       XMB=PMAS(24,1)
27297       IF(MOD(IFL,2).EQ.0) THEN
27298         KF1=KSUSY1+IFL-1
27299       ELSE
27300         KF1=KSUSY1+IFL+1
27301       ENDIF
27302       KF2=KF1+KSUSY1
27303       XMSF1=PMAS(PYCOMP(KF1),1)
27304       XMSF2=PMAS(PYCOMP(KF2),1)
27305       IF(XMI.GT.XMB+XMSF1) THEN
27306         IF(MOD(IFL,2).EQ.0) THEN
27307           IF(ILR.EQ.1) THEN
27308             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
27309           ELSE
27310             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
27311           ENDIF
27312         ELSE
27313           IF(ILR.EQ.1) THEN
27314             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
27315           ELSE
27316             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
27317           ENDIF
27318         ENDIF
27319         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27320         LKNT=LKNT+1
27321         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27322         IDLAM(LKNT,3)=0
27323         IDLAM(LKNT,1)=KF1
27324         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27325       ENDIF
27326       IF(XMI.GT.XMB+XMSF2) THEN
27327         IF(MOD(IFL,2).EQ.0) THEN
27328           IF(ILR.EQ.1) THEN
27329             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
27330           ELSE
27331             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
27332           ENDIF
27333         ELSE
27334           IF(ILR.EQ.1) THEN
27335             AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
27336           ELSE
27337             AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
27338           ENDIF
27339         ENDIF
27340         XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
27341         LKNT=LKNT+1
27342         XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
27343         IDLAM(LKNT,3)=0
27344         IDLAM(LKNT,1)=KF2
27345         IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
27346       ENDIF
27347
27348 C...SF -> SF' + HC
27349       XMB=PMAS(37,1)
27350       IF(MOD(IFL,2).EQ.0) THEN
27351         KF1=KSUSY1+IFL-1
27352       ELSE
27353         KF1=KSUSY1+IFL+1
27354       ENDIF
27355       KF2=KF1+KSUSY1
27356       XMSF1=PMAS(PYCOMP(KF1),1)
27357       XMSF2=PMAS(PYCOMP(KF2),1)
27358       IF(XMI.GT.XMB+XMSF1) THEN
27359         XMF=0D0
27360         XMFP=0D0
27361         AT=0D0
27362         AB=0D0
27363         IF(MOD(IFL,2).EQ.0) THEN
27364 C...T1-> B1 HC
27365           IF(ILR.EQ.1) THEN
27366             CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
27367             CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
27368             CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
27369             CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
27370 C...T2-> B1 HC
27371           ELSE
27372             CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
27373             CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
27374             CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
27375             CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
27376           ENDIF
27377           IF(IFL.EQ.6) THEN
27378             XMF=XMTOP
27379             XMFP=XMBOT
27380             AT=ATRIT
27381             AB=ATRIB
27382           ENDIF
27383         ELSE
27384 C...B1 -> T1 HC
27385           IF(ILR.EQ.1) THEN
27386             CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
27387             CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
27388             CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
27389             CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
27390 C...B2-> T1 HC
27391           ELSE
27392             CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
27393             CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
27394             CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
27395             CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
27396           ENDIF
27397           IF(IFL.EQ.5) THEN
27398             XMF=XMTOP
27399             XMFP=XMBOT
27400             AT=ATRIT
27401             AB=ATRIB
27402           ENDIF
27403         ENDIF
27404         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27405         LKNT=LKNT+1
27406         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27407      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27408      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27409         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27410         IDLAM(LKNT,3)=0
27411         IDLAM(LKNT,1)=KF1
27412         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27413       ENDIF
27414       IF(XMI.GT.XMB+XMSF2) THEN
27415         XMF=0D0
27416         XMFP=0D0
27417         AT=0D0
27418         AB=0D0
27419         IF(MOD(IFL,2).EQ.0) THEN
27420 C...T1-> B2 HC
27421           IF(ILR.EQ.1) THEN
27422             CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
27423             CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
27424             CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
27425             CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
27426 C...T2-> B2 HC
27427           ELSE
27428             CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
27429             CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
27430             CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
27431             CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
27432           ENDIF
27433           IF(IFL.EQ.6) THEN
27434             XMF=XMTOP
27435             XMFP=XMBOT
27436             AT=ATRIT
27437             AB=ATRIB
27438           ENDIF
27439         ELSE
27440 C...B1 -> T2 HC
27441           IF(ILR.EQ.1) THEN
27442             CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
27443             CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
27444             CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
27445             CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
27446 C...B2-> T2 HC
27447           ELSE
27448             CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
27449             CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
27450             CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
27451             CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
27452           ENDIF
27453           IF(IFL.EQ.5) THEN
27454             XMF=XMTOP
27455             XMFP=XMBOT
27456             AT=ATRIT
27457             AB=ATRIB
27458           ENDIF
27459         ENDIF
27460         XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
27461         LKNT=LKNT+1
27462         AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
27463      &  CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
27464      &  CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
27465         XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
27466         IDLAM(LKNT,3)=0
27467         IDLAM(LKNT,1)=KF2
27468         IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
27469       ENDIF
27470
27471 C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
27472
27473       IF(IFL.LE.6) THEN
27474         XMFP=0D0
27475         XMF=0D0
27476         IF(IFL.EQ.6) XMF=PMAS(6,1)
27477         IF(IFL.EQ.5) XMF=PMAS(5,1)
27478         XMJ=PMAS(PYCOMP(KSUSY1+21),1)
27479         AXMJ=ABS(XMJ)
27480         IF(XMI.GE.AXMJ+XMF) THEN
27481           AL=-SFMIX(IFL,2)
27482           BL=SFMIX(IFL,1)
27483           AR=-SFMIX(IFL,4)
27484           BR=SFMIX(IFL,3)
27485 C...F1 -> F CHI
27486           IF(ILR.EQ.1) THEN
27487             CA=AL
27488             CB=BL
27489 C...F2 -> F CHI
27490           ELSE
27491             CA=AR
27492             CB=BR
27493           ENDIF
27494           LKNT=LKNT+1
27495           XMA2=XMJ**2
27496           XMB2=XMF**2
27497           XL=PYLAMF(XMI2,XMA2,XMB2)
27498           XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
27499      &    (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF)
27500           IDLAM(LKNT,1)=KSUSY1+21
27501           IDLAM(LKNT,2)=IFL
27502           IDLAM(LKNT,3)=0
27503         ENDIF
27504       ENDIF
27505
27506 C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
27507       IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
27508      &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
27509 C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
27510 C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
27511 C...M*M = C1**2 * G**2/(16PI**2)
27512 C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
27513         LKNT=LKNT+1
27514         XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
27515         XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
27516         IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
27517         IDLAM(LKNT,1)=KSUSY1+22
27518         IDLAM(LKNT,2)=4
27519         IDLAM(LKNT,3)=0
27520       ENDIF
27521
27522       IKNT=LKNT
27523       XLAM(0)=0D0
27524       DO 130 I=1,IKNT
27525         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27526         XLAM(0)=XLAM(0)+XLAM(I)
27527   130 CONTINUE
27528       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
27529
27530       RETURN
27531       END
27532
27533 C*********************************************************************
27534
27535 *$ CREATE PYGLUI.FOR
27536 *COPY PYGLUI
27537 C...PYGLUI
27538 C...Calculates gluino decay modes.
27539
27540       SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
27541
27542 C...Double precision and integer declarations.
27543       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27544       INTEGER PYK,PYCHGE,PYCOMP
27545 C...Parameter statement to help give large particle numbers.
27546       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27547 C...Commonblocks.
27548       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27549       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27550       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27551       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27552      &SFMIX(16,4)
27553       COMMON/PYINTS/XXM(20)
27554       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
27555
27556 C...Local variables.
27557       INTEGER KFIN,KCIN,KF
27558       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
27559      &XMZ,XMZ2,AXMJ,AXMI
27560       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP
27561       DOUBLE PRECISION C1L,C1R,D1L,D1R
27562       DOUBLE PRECISION C2L,C2R,D2L,D2R
27563       DOUBLE PRECISION PYLAMF,XL
27564       DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
27565       DOUBLE PRECISION CA,CB,AL,AR,BL,BR
27566       DOUBLE PRECISION ALFA,BETA
27567       DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3
27568       DOUBLE PRECISION XLAM(0:200)
27569       INTEGER IDLAM(200,3)
27570       INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL
27571       DOUBLE PRECISION SR2
27572       DOUBLE PRECISION GAM
27573       DOUBLE PRECISION PYALEM,PI,PYALPS,EI
27574       DOUBLE PRECISION PYGAUS
27575       EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
27576       DOUBLE PRECISION PREC
27577       INTEGER KFNCHI(4),KFCCHI(2)
27578       DATA PI/3.141592654D0/
27579       DATA SR2/1.4142136D0/
27580       DATA PREC/1D-2/
27581       DATA KFNCHI/1000022,1000023,1000025,1000035/
27582       DATA KFCCHI/1000024,1000037/
27583
27584 C...COUNT THE NUMBER OF DECAY MODES
27585       LKNT=0
27586       IF(KFIN.NE.KSUSY1+21) RETURN
27587       KCIN=PYCOMP(KFIN)
27588
27589       XMW=PMAS(24,1)
27590       XMW2=XMW**2
27591       XMZ=PMAS(23,1)
27592       XMZ2=XMZ**2
27593       XW=PARU(102)
27594       TANW = SQRT(XW/(1D0-XW))
27595
27596       XMI=PMAS(KCIN,1)
27597       AXMI=ABS(XMI)
27598       XMI2=XMI**2
27599       AEM=PYALEM(XMI2)
27600       AS =PYALPS(XMI2)
27601       C1=AEM/XW
27602       XMI3=XMI**3
27603       BETA=ATAN(RMSS(5))
27604
27605 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
27606
27607       IF(IMSS(11).EQ.1) THEN
27608         XMP=RMSS(28)
27609         IDG=39+KSUSY1
27610         XMGR=PMAS(PYCOMP(IDG),1)
27611         XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
27612         IF(AXMI.GT.XMGR) THEN
27613           LKNT=LKNT+1
27614           IDLAM(LKNT,1)=IDG
27615           IDLAM(LKNT,2)=21
27616           IDLAM(LKNT,3)=0
27617           XLAM(LKNT)=XFAC
27618         ENDIF
27619       ENDIF
27620
27621 C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
27622
27623       DO 110 IFL=1,6
27624         DO 100 ILR=1,2
27625           XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
27626           AXMJ=ABS(XMJ)
27627           XMF=PMAS(IFL,1)
27628           IDU=3-(1+MOD(IFL,2))
27629           IF(XMI.GE.AXMJ+XMF) THEN
27630             AL=SFMIX(IFL,1)
27631             BL=SFMIX(IFL,2)
27632             AR=SFMIX(IFL,3)
27633             BR=SFMIX(IFL,4)
27634 C...F1 -> F CHI
27635             IF(ILR.EQ.1) THEN
27636               CA=AL
27637               CB=BL
27638 C...F2 -> F CHI
27639             ELSE
27640               CA=AR
27641               CB=BR
27642             ENDIF
27643             LKNT=LKNT+1
27644             XMA2=XMJ**2
27645             XMB2=XMF**2
27646             XL=PYLAMF(XMI2,XMA2,XMB2)
27647             XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
27648      &      (CA**2+CB**2)+4D0*CA*CB*XMI*XMF)
27649             IDLAM(LKNT,1)=ILR*KSUSY1+IFL
27650             IDLAM(LKNT,2)=-IFL
27651             IDLAM(LKNT,3)=0
27652             LKNT=LKNT+1
27653             XLAM(LKNT)=XLAM(LKNT-1)
27654             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27655             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27656             IDLAM(LKNT,3)=0
27657           ENDIF
27658   100   CONTINUE
27659   110 CONTINUE
27660
27661 C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
27662 C...GLUINO -> NI Q QBAR
27663       DO 160 IX=1,4
27664         XMJ=SMZ(IX)
27665         AXMJ=ABS(XMJ)
27666         IF(XMI.GE.AXMJ) THEN
27667           XXM(1)=0D0
27668           XXM(2)=XMJ
27669           XXM(3)=0D0
27670           XXM(4)=XMI
27671           XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
27672           XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
27673           XXM(7)=1D6
27674           XXM(8)=0D0
27675           XXM(9)=0D0
27676           XXM(10)=0D0
27677           S12MIN=0D0
27678           S12MAX=(XMI-AXMJ)**2
27679 C...D-TYPE QUARKS
27680           XXM(11)=0D0
27681           XXM(12)=0D0
27682           XXM(13)=1D0
27683           XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27684           XXM(15)=1D0
27685           XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
27686           IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120
27687           IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
27688             LKNT=LKNT+1
27689             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27690      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27691             IDLAM(LKNT,1)=KFNCHI(IX)
27692             IDLAM(LKNT,2)=1
27693             IDLAM(LKNT,3)=-1
27694           ENDIF
27695           IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
27696             LKNT=LKNT+1
27697             XLAM(LKNT)=XLAM(LKNT-1)
27698             IDLAM(LKNT,1)=KFNCHI(IX)
27699             IDLAM(LKNT,2)=3
27700             IDLAM(LKNT,3)=-3
27701           ENDIF
27702   120     CONTINUE
27703           IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130
27704           IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
27705             CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM)
27706             LKNT=LKNT+1
27707             XLAM(LKNT)=GAM
27708             IDLAM(LKNT,1)=KFNCHI(IX)
27709             IDLAM(LKNT,2)=5
27710             IDLAM(LKNT,3)=-5
27711           ENDIF
27712 C...U-TYPE QUARKS
27713   130     CONTINUE
27714           XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
27715           XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
27716           XXM(13)=1D0
27717           XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
27718           XXM(15)=1D0
27719           XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
27720           IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140
27721           IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
27722             LKNT=LKNT+1
27723             XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
27724      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2)
27725             IDLAM(LKNT,1)=KFNCHI(IX)
27726             IDLAM(LKNT,2)=2
27727             IDLAM(LKNT,3)=-2
27728           ENDIF
27729           IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
27730             LKNT=LKNT+1
27731             XLAM(LKNT)=XLAM(LKNT-1)
27732             IDLAM(LKNT,1)=KFNCHI(IX)
27733             IDLAM(LKNT,2)=4
27734             IDLAM(LKNT,3)=-4
27735           ENDIF
27736   140     CONTINUE
27737 C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
27738 C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
27739           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150
27740           XMF=PMAS(6,1)
27741           IF(XMI.GE.AXMJ+2D0*XMF) THEN
27742             CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM)
27743             LKNT=LKNT+1
27744             XLAM(LKNT)=GAM
27745             IDLAM(LKNT,1)=KFNCHI(IX)
27746             IDLAM(LKNT,2)=6
27747             IDLAM(LKNT,3)=-6
27748           ENDIF
27749   150     CONTINUE
27750         ENDIF
27751   160 CONTINUE
27752
27753 C...GLUINO -> CI Q QBAR'
27754       DO 190 IX=1,2
27755         XMJ=SMW(IX)
27756         AXMJ=ABS(XMJ)
27757         IF(XMI.GE.AXMJ) THEN
27758           S12MIN=0D0
27759           S12MAX=(AXMI-AXMJ)**2
27760           XXM(1)=0D0
27761           XXM(2)=XMJ
27762           XXM(3)=0D0
27763           XXM(4)=XMI
27764           XXM(5)=0D0
27765           XXM(6)=0D0
27766           XXM(9)=1D6
27767           XXM(10)=0D0
27768           XXM(7)=UMIX(IX,1)*SR2
27769           XXM(8)=VMIX(IX,1)*SR2
27770           XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
27771           XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
27772           IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170
27773           IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
27774             LKNT=LKNT+1
27775             XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
27776      &      PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
27777             IDLAM(LKNT,1)=KFCCHI(IX)
27778             IDLAM(LKNT,2)=1
27779             IDLAM(LKNT,3)=-2
27780             LKNT=LKNT+1
27781             XLAM(LKNT)=XLAM(LKNT-1)
27782             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27783             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27784             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27785           ENDIF
27786           IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
27787             LKNT=LKNT+1
27788             XLAM(LKNT)=XLAM(LKNT-1)
27789             IDLAM(LKNT,1)=KFCCHI(IX)
27790             IDLAM(LKNT,2)=3
27791             IDLAM(LKNT,3)=-4
27792             LKNT=LKNT+1
27793             XLAM(LKNT)=XLAM(LKNT-1)
27794             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27795             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27796             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27797           ENDIF
27798   170     CONTINUE
27799
27800           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180
27801           IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180
27802           XMF=PMAS(6,1)
27803           XMFP=PMAS(5,1)
27804           IF(XMI.GE.AXMJ+XMF+XMFP) THEN
27805             CALL PYTBBC(IX,80,AXMI,GAM)
27806             LKNT=LKNT+1
27807             XLAM(LKNT)=GAM
27808             IDLAM(LKNT,1)=KFCCHI(IX)
27809             IDLAM(LKNT,2)=5
27810             IDLAM(LKNT,3)=-6
27811             LKNT=LKNT+1
27812             XLAM(LKNT)=XLAM(LKNT-1)
27813             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
27814             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
27815             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
27816           ENDIF
27817   180     CONTINUE
27818         ENDIF
27819   190 CONTINUE
27820
27821       IKNT=LKNT
27822       XLAM(0)=0D0
27823       DO 200 I=1,IKNT
27824         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
27825         XLAM(0)=XLAM(0)+XLAM(I)
27826   200 CONTINUE
27827       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
27828
27829       RETURN
27830       END
27831
27832 C*********************************************************************
27833
27834 *$ CREATE PYTBBN.FOR
27835 *COPY PYTBBN
27836 C...PYTBBN
27837 C...Calculates the three-body decay of gluinos into
27838 C...neutralinos and third generation fermions.
27839
27840       SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
27841
27842 C...Double precision and integer declarations.
27843       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27844       INTEGER PYK,PYCHGE,PYCOMP
27845 C...Parameter statement to help give large particle numbers.
27846       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
27847 C...Commonblocks.
27848       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27849       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27850       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27851       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27852      &SFMIX(16,4)
27853       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
27854
27855 C...Local variables.
27856       EXTERNAL PYSIMP,PYLAMF
27857       INTEGER LIN,NN
27858       DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
27859       DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
27860       DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
27861       DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
27862       DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
27863       DOUBLE PRECISION XLN1,XLN2,B1,B2
27864       DOUBLE PRECISION E,XMGLU,GAM
27865       DOUBLE PRECISION PYSIMP,PYLAMF
27866       DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
27867       SAVE HRB,HLB,FLB,FRB
27868       DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
27869       DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
27870       SAVE HLT,HRT,FLT,FRT
27871       DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4),
27872      &FLD(4),FRD(4)
27873       SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD
27874       DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
27875       DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
27876       SAVE AMSB,AMST
27877       DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
27878       DOUBLE PRECISION ROT1(4,4)
27879       LOGICAL IFIRST
27880       SAVE IFIRST
27881       DATA IFIRST/.TRUE./
27882
27883       TANB=RMSS(5)
27884       SINB=TANB/SQRT(1D0+TANB**2)
27885       COSB=SINB/TANB
27886       XW=PARU(102)
27887       SINW=SQRT(XW)
27888       COSW=SQRT(1D0-XW)
27889       TANW=SINW/COSW
27890       AMW=PMAS(24,1)
27891       COSC=SFMIX(5,1)
27892       SINC=SFMIX(5,3)
27893       COSA=SFMIX(6,1)
27894       SINA=SFMIX(6,3)
27895       AMBOT=0D0
27896       AMTOP=PYRNMT(PMAS(6,1))
27897       W2=SQRT(2D0)
27898       FAKT1=AMBOT/W2/AMW/COSB
27899       FAKT2=AMTOP/W2/AMW/SINB
27900       IF(IFIRST) THEN
27901         DO 110 II=1,4
27902           AMN(II)=SMZ(II)
27903           DO 100 J=1,4
27904             ROT1(II,J)=0D0
27905             AN(II,J)=0D0
27906   100     CONTINUE
27907   110   CONTINUE
27908         ROT1(1,1)=COSW
27909         ROT1(1,2)=-SINW
27910         ROT1(2,1)=-ROT1(1,2)
27911         ROT1(2,2)=ROT1(1,1)
27912         ROT1(3,3)=COSB
27913         ROT1(3,4)=SINB
27914         ROT1(4,3)=-ROT1(3,4)
27915         ROT1(4,4)=ROT1(3,3)
27916         DO 140 II=1,4
27917           DO 130 J=1,4
27918             DO 120 JJ=1,4
27919               AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
27920   120       CONTINUE
27921   130     CONTINUE
27922   140   CONTINUE
27923         DO 150 J=1,4
27924           ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
27925           ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27926           ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
27927      &    XW)*AN(J,2)/COSW
27928           HRT(J)=ZN(1)*COSA-ZN(3)*SINA
27929           HLT(J)=ZN(1)*COSA+ZN(2)*SINA
27930           FLT(J)=ZN(3)*COSA+ZN(1)*SINA
27931           FRT(J)=ZN(2)*COSA-ZN(1)*SINA
27932           FLU(J)=ZN(3)
27933           FRU(J)=ZN(2)
27934           ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
27935           ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
27936           ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
27937           HRB(J)=ZN(1)*COSC-ZN(3)*SINC
27938           HLB(J)=ZN(1)*COSC+ZN(2)*SINC
27939           FLB(J)=ZN(3)*COSC+ZN(1)*SINC
27940           FRB(J)=ZN(2)*COSC-ZN(1)*SINC
27941           FLD(J)=ZN(3)
27942           FRD(J)=ZN(2)
27943   150   CONTINUE
27944         AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
27945         AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
27946         AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
27947         AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
27948         IFIRST=.FALSE.
27949       ENDIF
27950
27951       IF(NINT(3D0*E).EQ.2) THEN
27952         HL=HLT(I)
27953         HR=HRT(I)
27954         FL=FLT(I)
27955         FR=FRT(I)
27956         COSD=SFMIX(6,1)
27957         SIND=SFMIX(6,3)
27958         XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
27959         XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
27960         XM=PMAS(6,1)
27961       ELSE
27962         HL=HLB(I)
27963         HR=HRB(I)
27964         FL=FLB(I)
27965         FR=FRB(I)
27966         COSD=SFMIX(5,1)
27967         SIND=SFMIX(5,3)
27968         XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
27969         XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
27970         XM=PMAS(5,1)
27971       ENDIF
27972       COSD2=COSD*COSD
27973       SIND2=SIND*SIND
27974       COS2D=COSD2-SIND2
27975       SIN2D=SIND*COSD*2D0
27976       HL2=HL*HL
27977       HR2=HR*HR
27978       FL2=FL*FL
27979       FR2=FR*FR
27980       FF=FL*FR
27981       HH=HL*HR
27982       HFL=HL*FL
27983       HFR=HR*FR
27984       HRFL=HR*FL
27985       HLFR=HL*FR
27986       XM2=XM*XM
27987       XMG=XMGLU
27988       XMG2=XMG*XMG
27989       ALPHAW=PYALEM(XMG2)
27990       ALPHAS=PYALPS(XMG2)
27991       XMR=AMN(I)
27992       XMR2=XMR*XMR
27993       XMQ4=XMG*XM2*XMR
27994       XM24=(XMG2+XM2)*(XM2+XMR2)
27995       SMIN=4D0*XM2
27996       SMAX=(XMG-ABS(XMR))**2
27997       XMQA=XMG2+2D0*XM2+XMR2
27998       DO 170 LIN=1,NN-1
27999         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28000         GRS=SBAR-XMQA
28001         W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
28002         W=DSQRT(W)
28003         XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
28004         XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
28005         B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
28006         B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
28007         G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
28008      &  +2D0*(FF*SIND2-HH*COSD2))*W
28009         G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
28010      &  +4D0*HFL*XM*XMR)*XLN1
28011      &  +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
28012      &  +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
28013      &  -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
28014      &  +8D0*HFL*XMQ4*SIN2D)*B1
28015         G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
28016      &  +4D0*HFR*XMR*XM)*XLN2
28017      &  +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
28018      &  +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
28019      &  +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
28020      &  -8D0*HFR*XMQ4*SIN2D)*B2
28021         G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
28022      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
28023      &  -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
28024      &  +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
28025      &  -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
28026         G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
28027      &  (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
28028      &  +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
28029         G(5)=(2D0*(HH*COSD2-FF*SIND2)
28030      &  *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
28031      &  +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
28032      &  +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
28033      &  *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
28034      &  +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
28035      &  +COS2D*XM*(SBAR+XMG2-XMR2))
28036      &  +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
28037      &  *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
28038         G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
28039      &  +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
28040      &  -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
28041      &  -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
28042      &  -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
28043         SUMME(LIN)=0D0
28044         DO 160 J=0,6
28045           SUMME(LIN)=SUMME(LIN)+G(J)
28046   160   CONTINUE
28047   170 CONTINUE
28048       SUMME(0)=0D0
28049       SUMME(NN)=0D0
28050       GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28051      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28052
28053       RETURN
28054       END
28055
28056 C*********************************************************************
28057
28058 *$ CREATE PYTBBC.FOR
28059 *COPY PYTBBC
28060 C...PYTBBC
28061 C...Calculates the three-body decay of gluinos into
28062 C...charginos and third generation fermions.
28063
28064       SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
28065
28066 C...Double precision and integer declarations.
28067       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28068       INTEGER PYK,PYCHGE,PYCOMP
28069 C...Parameter statement to help give large particle numbers.
28070       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28071 C...Commonblocks.
28072       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28073       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28074       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28075       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28076      &SFMIX(16,4)
28077       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
28078
28079 C...Local variables.
28080       EXTERNAL PYSIMP,PYLAMF
28081       INTEGER I,NN,LIN
28082       DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
28083       DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
28084       DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
28085       DOUBLE PRECISION SUMME(0:100),A(4,8)
28086       DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
28087       DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
28088       DOUBLE PRECISION XMGLU,GAM
28089       DOUBLE PRECISION PYSIMP,PYLAMF
28090       DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
28091      &DDD(2),EEE(2),FFF(2)
28092       SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
28093       DOUBLE PRECISION ALPHAW,ALPHAS,GSU2
28094       DOUBLE PRECISION AMC(2),AMN(4)
28095       SAVE AMC,AMN
28096       DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
28097       DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
28098       SAVE AMSB,AMST
28099       DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2
28100       LOGICAL IFIRST
28101       SAVE IFIRST
28102       DATA IFIRST/.TRUE./
28103
28104       TANB=RMSS(5)
28105       SINB=TANB/SQRT(1D0+TANB**2)
28106       COSB=SINB/TANB
28107       XW=PARU(102)
28108       SINW=SQRT(XW)
28109       COSW=SQRT(1D0-XW)
28110       AMW=PMAS(24,1)
28111       COSC=SFMIX(5,1)
28112       SINC=SFMIX(5,3)
28113       COSA=SFMIX(6,1)
28114       SINA=SFMIX(6,3)
28115       AMBOT=0D0
28116       AMTOP=PYRNMT(PMAS(6,1))
28117       W2=SQRT(2D0)
28118       AMW=PMAS(24,1)
28119       FAKT1=AMBOT/W2/AMW/COSB
28120       FAKT2=AMTOP/W2/AMW/SINB
28121       IF(IFIRST) THEN
28122         AMC(1)=SMW(1)
28123         AMC(2)=SMW(2)
28124         DO 100 JJ=1,2
28125           CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
28126           EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
28127           DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
28128           FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
28129           XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
28130           AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
28131           XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
28132           BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
28133   100   CONTINUE
28134         AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
28135         AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
28136         AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
28137         AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
28138         IFIRST=.FALSE.
28139       ENDIF
28140       AMTOP=PMAS(6,1)
28141
28142       ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
28143       ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
28144       VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
28145       VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
28146
28147       COS2A=COSA**2-SINA**2
28148       SIN2A=SINA*COSA*2D0
28149       COS2C=COSC**2-SINC**2
28150       SIN2C=SINC*COSC*2D0
28151
28152       XMG=XMGLU
28153       XMT=AMTOP
28154       XMB=0D0
28155       XMR=AMC(I)
28156       XMG2=XMG*XMG
28157       ALPHAW=PYALEM(XMG2)
28158       ALPHAS=PYALPS(XMG2)
28159       XMT2=XMT*XMT
28160       XMB2=XMB*XMB
28161       XMR2=XMR*XMR
28162       XMQ2=XMG2+XMT2+XMB2+XMR2
28163       XMQ4=XMG*XMT*XMB*XMR
28164       XMQ3=XMG2*XMR2+XMT2*XMB2
28165       XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
28166       XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
28167
28168       XMST(1)=AMST(1)*AMST(1)
28169       XMST(2)=AMST(1)*AMST(1)
28170       XMST(3)=AMST(2)*AMST(2)
28171       XMST(4)=AMST(2)*AMST(2)
28172       XMSB(1)=AMSB(1)*AMSB(1)
28173       XMSB(2)=AMSB(2)*AMSB(2)
28174       XMSB(3)=AMSB(1)*AMSB(1)
28175       XMSB(4)=AMSB(2)*AMSB(2)
28176
28177       A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
28178       A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
28179       A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
28180       A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
28181       A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
28182       A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
28183       A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
28184       A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
28185
28186       A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
28187       A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
28188       A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
28189       A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
28190       A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
28191       A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
28192       A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
28193       A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
28194
28195       A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
28196       A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
28197       A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
28198       A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
28199       A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
28200       A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
28201       A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
28202       A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
28203
28204       A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
28205       A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
28206       A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
28207       A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
28208       A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
28209       A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
28210       A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
28211       A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
28212
28213       SMAX=(XMG-ABS(XMR))**2
28214       SMIN=(XMB+XMT)**2+0.1D0
28215
28216       DO 120 LIN=0,NN-1
28217         SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
28218         AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
28219         GRS=SBAR-XMQ2
28220         W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
28221         W=DSQRT(W)/2D0/SBAR
28222         ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
28223         ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
28224         ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
28225         ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
28226         SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
28227      &  +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
28228      &  +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
28229      &  -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
28230      &  +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
28231      &  +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
28232      &  *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
28233         SUMME(LIN)=SUMME(LIN)-ULR(2)*W
28234      &  +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
28235      &  -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
28236      &  +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
28237      &  +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
28238      &  -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
28239      &  +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
28240      &  *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
28241         SUMME(LIN)=SUMME(LIN)-VLR(1)*W
28242      &  +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
28243      &  +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
28244      &  +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
28245      &  -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
28246      &  +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
28247      &  +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
28248      &  *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
28249         SUMME(LIN)=SUMME(LIN)-VLR(2)*W
28250      &  +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
28251      &  -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
28252      &  +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
28253      &  +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
28254      &  -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
28255      &  +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
28256      &  *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
28257         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
28258      &  *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
28259      &  *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
28260      &  +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
28261         SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
28262      &  *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
28263      &  *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
28264      &  +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
28265         DO 110 J=1,4
28266           SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
28267      &    +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
28268      &    +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
28269      &    +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
28270      &    -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
28271      &    -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
28272      &    *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
28273      &    -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
28274      &    +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
28275      &    +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
28276      &    -A(J,6)*(XMG2+XMR2-SBAR)
28277      &    -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
28278      &    *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
28279      &    /(GRS+XMSB(J)+XMST(J))
28280   110   CONTINUE
28281   120 CONTINUE
28282       SUMME(NN)=0D0
28283       GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
28284      &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
28285
28286       RETURN
28287       END
28288
28289 C*********************************************************************
28290
28291 *$ CREATE PYNJDC.FOR
28292 *COPY PYNJDC
28293 C...PYNJDC
28294 C...Calculates decay widths for the neutralinos (admixtures of
28295 C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
28296
28297 C...Input:  KCIN = KF code for particle
28298 C...Output: XLAM = widths
28299 C...        IDLAM = KF codes for decay particles
28300 C...        IKNT = number of decay channels defined
28301 C...AUTHOR: STEPHEN MRENNA
28302 C...Last change:
28303 C...10-15-95:  force decay chi^0_2 -> chi^0_1 + gamma
28304 C...when CHIGAMMA .NE. 0
28305 C...10 FEB 96:  Calculate this decay for small tan(beta)
28306
28307       SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
28308
28309 C...Double precision and integer declarations.
28310       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28311       INTEGER PYK,PYCHGE,PYCOMP
28312 C...Parameter statement to help give large particle numbers.
28313       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
28314 C...Commonblocks.
28315       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28316       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28317       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28318       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28319      &SFMIX(16,4)
28320       COMMON/PYINTS/XXM(20)
28321       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
28322
28323 C...Local variables.
28324       INTEGER KFIN,KCIN
28325       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
28326      &XMZ,XMZ2,AXMJ,AXMI
28327       DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK
28328       DOUBLE PRECISION S12MIN,S12MAX
28329       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
28330       DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ
28331       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3
28332       DOUBLE PRECISION PYX2XH,PYX2XG
28333       DOUBLE PRECISION XLAM(0:200)
28334       INTEGER IDLAM(200,3)
28335       INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
28336       INTEGER ITH(3),KF1,KF2
28337       INTEGER ITHC
28338       DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
28339       DOUBLE PRECISION SR2
28340       DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K
28341       DOUBLE PRECISION GAMCON,XMT1,XMT2
28342       DOUBLE PRECISION PYALEM,PI,PYALPS
28343       DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP
28344       DOUBLE PRECISION RAT1,RAT2
28345       DOUBLE PRECISION T3T,CA,CB,FCOL
28346       DOUBLE PRECISION ALFA,BETA,TANB
28347       DOUBLE PRECISION PYGAUS,PYXXGA
28348       EXTERNAL PYXXW5,PYGAUS,PYXXZ5
28349       DOUBLE PRECISION PREC
28350       INTEGER KFNCHI(4),KFCCHI(2)
28351       DATA ETAH/1D0,1D0,-1D0/
28352       DATA ITH/25,35,36/
28353       DATA ITHC/37/
28354       DATA PREC/1D-2/
28355       DATA PI/3.141592654D0/
28356       DATA SR2/1.4142136D0/
28357       DATA KFNCHI/1000022,1000023,1000025,1000035/
28358       DATA KFCCHI/1000024,1000037/
28359
28360 C...COUNT THE NUMBER OF DECAY MODES
28361       LKNT=0
28362
28363       XMW=PMAS(24,1)
28364       XMW2=XMW**2
28365       XMZ=PMAS(23,1)
28366       XMZ2=XMZ**2
28367       XW=1D0-XMW2/XMZ2
28368       TANW = SQRT(XW/(1D0-XW))
28369
28370 C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
28371       KCIN=PYCOMP(KFIN)
28372       IX=1
28373       IF(KFIN.EQ.KFNCHI(2)) IX=2
28374       IF(KFIN.EQ.KFNCHI(3)) IX=3
28375       IF(KFIN.EQ.KFNCHI(4)) IX=4
28376
28377       XMI=SMZ(IX)
28378       XMI2=XMI**2
28379       AXMI=ABS(XMI)
28380       AEM=PYALEM(XMI2)
28381       AS =PYALPS(XMI2)
28382       C1=AEM/XW
28383       XMI3=ABS(XMI**3)
28384
28385       TANB=RMSS(5)
28386       BETA=ATAN(TANB)
28387       ALFA=RMSS(18)
28388       CBETA=COS(BETA)
28389       SBETA=TANB*CBETA
28390       CALFA=COS(ALFA)
28391       SALFA=SIN(ALFA)
28392
28393 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
28394       IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN
28395         RETURN
28396       ENDIF
28397
28398 C...FORCE CHI0_2 -> CHI0_1 + GAMMA
28399       IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
28400         XMJ=SMZ(1)
28401         AXMJ=ABS(XMJ)
28402         LKNT=LKNT+1
28403         GAMCON=AEM**3/8D0/PI/XMW2/XW
28404         XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28405         XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28406         XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28407         IDLAM(LKNT,1)=KSUSY1+22
28408         IDLAM(LKNT,2)=22
28409         IDLAM(LKNT,3)=0
28410         WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
28411         GOTO 290
28412       ENDIF
28413
28414 C...GRAVITINO DECAY MODES
28415
28416       IF(IMSS(11).EQ.1) THEN
28417         XMP=RMSS(28)
28418         IDG=39+KSUSY1
28419         XMGR=PMAS(PYCOMP(IDG),1)
28420         SINW=SQRT(XW)
28421         COSW=SQRT(1D0-XW)
28422         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
28423         IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
28424           LKNT=LKNT+1
28425           IDLAM(LKNT,1)=IDG
28426           IDLAM(LKNT,2)=22
28427           IDLAM(LKNT,3)=0
28428           XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2
28429         ENDIF
28430         IF(AXMI.GT.XMGR+XMZ) THEN
28431           LKNT=LKNT+1
28432           IDLAM(LKNT,1)=IDG
28433           IDLAM(LKNT,2)=23
28434           IDLAM(LKNT,3)=0
28435           XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 +
28436      $  .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4
28437         ENDIF
28438         IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
28439           LKNT=LKNT+1
28440           IDLAM(LKNT,1)=IDG
28441           IDLAM(LKNT,2)=25
28442           IDLAM(LKNT,3)=0
28443           XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)*
28444      $  .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
28445         ENDIF
28446         IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
28447           LKNT=LKNT+1
28448           IDLAM(LKNT,1)=IDG
28449           IDLAM(LKNT,2)=35
28450           IDLAM(LKNT,3)=0
28451           XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)*
28452      $  .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
28453         ENDIF
28454         IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
28455           LKNT=LKNT+1
28456           IDLAM(LKNT,1)=IDG
28457           IDLAM(LKNT,2)=36
28458           IDLAM(LKNT,3)=0
28459           XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)*
28460      $  .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
28461         ENDIF
28462       ENDIF
28463
28464       DO 180 IJ=1,IX-1
28465         XMJ=SMZ(IJ)
28466         AXMJ=ABS(XMJ)
28467         XMJ2=XMJ**2
28468
28469 C...CHI0_I -> CHI0_J + GAMMA
28470         IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
28471           RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2
28472           RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 )
28473           RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2
28474           RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 )
28475           IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
28476      &    (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
28477             LKNT=LKNT+1
28478             IDLAM(LKNT,1)=KFNCHI(IJ)
28479             IDLAM(LKNT,2)=22
28480             IDLAM(LKNT,3)=0
28481             GAMCON=AEM**3/8D0/PI/XMW2/XW
28482             XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
28483             XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
28484             XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
28485           ENDIF
28486         ENDIF
28487
28488 C...CHI0_I -> CHI0_J + Z0
28489         IF(AXMI.GE.AXMJ+XMZ) THEN
28490           LKNT=LKNT+1
28491           GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28492           GR=-GL
28493           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
28494           IDLAM(LKNT,1)=KFNCHI(IJ)
28495           IDLAM(LKNT,2)=23
28496           IDLAM(LKNT,3)=0
28497         ELSEIF(AXMI.GE.AXMJ) THEN
28498           FID=11
28499           EI=KCHG(FID,1)/3D0
28500           T3=-0.5D0
28501           XXM(1)=0D0
28502           XXM(2)=XMJ
28503           XXM(3)=0D0
28504           XXM(4)=XMI
28505           XXM(5)=PMAS(PYCOMP(KSUSY1+11),1)
28506           XXM(6)=PMAS(PYCOMP(KSUSY2+11),1)
28507           XXM(7)=XMZ
28508           XXM(8)=PMAS(23,2)
28509           XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4))
28510           XXM(10)=-XXM(9)
28511           XXM(11)=(T3-EI*XW)/(1D0-XW)
28512           XXM(12)=-EI*XW/(1D0-XW)
28513           XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28514           XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28515           XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28516           XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28517           S12MIN=0D0
28518           S12MAX=(AXMI-AXMJ)**2
28519
28520 C...CHARGED LEPTONS
28521           IF( XXM(5).LT.AXMI ) THEN
28522             XXM(5)=1D6
28523           ENDIF
28524           IF(XXM(6).LT.AXMI ) THEN
28525             XXM(6)=1D6
28526           ENDIF
28527           IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
28528             LKNT=LKNT+1
28529             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28530      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28531             IDLAM(LKNT,1)=KFNCHI(IJ)
28532             IDLAM(LKNT,2)=11
28533             IDLAM(LKNT,3)=-11
28534             IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
28535               LKNT=LKNT+1
28536               XLAM(LKNT)=XLAM(LKNT-1)
28537               IDLAM(LKNT,1)=KFNCHI(IJ)
28538               IDLAM(LKNT,2)=13
28539               IDLAM(LKNT,3)=-13
28540             ENDIF
28541           ENDIF
28542   100     CONTINUE
28543           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28544             XXM(5)=PMAS(PYCOMP(KSUSY1+15),1)
28545             XXM(6)=PMAS(PYCOMP(KSUSY2+15),1)
28546           ELSE
28547             XXM(6)=PMAS(PYCOMP(KSUSY1+15),1)
28548             XXM(5)=PMAS(PYCOMP(KSUSY2+15),1)
28549           ENDIF
28550           IF( XXM(5).LT.AXMI ) THEN
28551             XXM(5)=1D6
28552           ENDIF
28553           IF(XXM(6).LT.AXMI ) THEN
28554             XXM(6)=1D6
28555           ENDIF
28556
28557           IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
28558             LKNT=LKNT+1
28559             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28560      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28561             IDLAM(LKNT,1)=KFNCHI(IJ)
28562             IDLAM(LKNT,2)=15
28563             IDLAM(LKNT,3)=-15
28564           ENDIF
28565
28566 C...NEUTRINOS
28567   110     CONTINUE
28568           FID=12
28569           EI=KCHG(FID,1)/3D0
28570           T3=0.5D0
28571           XXM(5)=PMAS(PYCOMP(KSUSY1+12),1)
28572           XXM(6)=1D6
28573           XXM(11)=(T3-EI*XW)/(1D0-XW)
28574           XXM(12)=-EI*XW/(1D0-XW)
28575           XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28576           XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28577           XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28578           XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28579
28580           IF( XXM(5).LT.AXMI ) THEN
28581             XXM(5)=1D6
28582           ENDIF
28583
28584           LKNT=LKNT+1
28585           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28586      &    PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28587           IDLAM(LKNT,1)=KFNCHI(IJ)
28588           IDLAM(LKNT,2)=12
28589           IDLAM(LKNT,3)=-12
28590           LKNT=LKNT+1
28591           XLAM(LKNT)=XLAM(LKNT-1)
28592           IDLAM(LKNT,1)=KFNCHI(IJ)
28593           IDLAM(LKNT,2)=14
28594           IDLAM(LKNT,3)=-14
28595   120     CONTINUE
28596           XXM(5)=PMAS(PYCOMP(KSUSY1+16),1)
28597           IF( XXM(5).LT.AXMI ) THEN
28598             XXM(5)=1D6
28599           ENDIF
28600           LKNT=LKNT+1
28601           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28602      &    PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
28603           IDLAM(LKNT,1)=KFNCHI(IJ)
28604           IDLAM(LKNT,2)=16
28605           IDLAM(LKNT,3)=-16
28606
28607 C...D-TYPE QUARKS
28608   130     CONTINUE
28609           XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28610           XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28611           FID=1
28612           EI=KCHG(FID,1)/3D0
28613           T3=-0.5D0
28614
28615           XXM(11)=(T3-EI*XW)/(1D0-XW)
28616           XXM(12)=-EI*XW/(1D0-XW)
28617           XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28618           XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28619           XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28620           XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28621
28622           IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140
28623           IF( XXM(5).LT.AXMI ) THEN
28624             XXM(5)=1D6
28625           ELSEIF( XXM(6).LT.AXMI ) THEN
28626             XXM(6)=1D6
28627           ENDIF
28628           IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
28629             LKNT=LKNT+1
28630             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28631      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28632             IDLAM(LKNT,1)=KFNCHI(IJ)
28633             IDLAM(LKNT,2)=1
28634             IDLAM(LKNT,3)=-1
28635             IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
28636               LKNT=LKNT+1
28637               XLAM(LKNT)=XLAM(LKNT-1)
28638               IDLAM(LKNT,1)=KFNCHI(IJ)
28639               IDLAM(LKNT,2)=3
28640               IDLAM(LKNT,3)=-3
28641             ENDIF
28642           ENDIF
28643   140     CONTINUE
28644           IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
28645             XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
28646             XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
28647           ELSE
28648             XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
28649             XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
28650           ENDIF
28651           IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150
28652           IF(XXM(5).LT.AXMI) THEN
28653             XXM(5)=1D6
28654           ELSEIF(XXM(6).LT.AXMI) THEN
28655             XXM(6)=1D6
28656           ENDIF
28657           IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
28658             LKNT=LKNT+1
28659             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28660      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28661             IDLAM(LKNT,1)=KFNCHI(IJ)
28662             IDLAM(LKNT,2)=5
28663             IDLAM(LKNT,3)=-5
28664           ENDIF
28665
28666 C...U-TYPE QUARKS
28667   150     CONTINUE
28668           XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
28669           XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
28670           FID=2
28671           EI=KCHG(FID,1)/3D0
28672           T3=0.5D0
28673
28674           XXM(11)=(T3-EI*XW)/(1D0-XW)
28675           XXM(12)=-EI*XW/(1D0-XW)
28676           XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))
28677           XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))
28678           XXM(15)=SR2*TANW*(EI*ZMIX(IX,1))
28679           XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1))
28680
28681           IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160
28682           IF(XXM(5).LT.AXMI) THEN
28683             XXM(5)=1D6
28684           ELSEIF(XXM(6).LT.AXMI) THEN
28685             XXM(6)=1D6
28686           ENDIF
28687           IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
28688             LKNT=LKNT+1
28689             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28690      &      PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0
28691             IDLAM(LKNT,1)=KFNCHI(IJ)
28692             IDLAM(LKNT,2)=2
28693             IDLAM(LKNT,3)=-2
28694             IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
28695               LKNT=LKNT+1
28696               XLAM(LKNT)=XLAM(LKNT-1)
28697               IDLAM(LKNT,1)=KFNCHI(IJ)
28698               IDLAM(LKNT,2)=4
28699               IDLAM(LKNT,3)=-4
28700             ENDIF
28701           ENDIF
28702   160     CONTINUE
28703         ENDIF
28704
28705 C...CHI0_I -> CHI0_J + H0_K
28706         EH(1)=SIN(ALFA)
28707         EH(2)=COS(ALFA)
28708         EH(3)=-SIN(BETA)
28709         DH(1)=COS(ALFA)
28710         DH(2)=-SIN(ALFA)
28711         DH(3)=COS(BETA)
28712
28713         QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)-
28714      &  TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1))
28715         RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)-
28716      &  TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1))
28717
28718         DO 170 IH=1,3
28719           XMH=PMAS(ITH(IH),1)
28720           XMH2=XMH**2
28721           IF(AXMI.GE.AXMJ+XMH) THEN
28722             LKNT=LKNT+1
28723             XL=PYLAMF(XMI2,XMJ2,XMH2)
28724             F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
28725             F12K=F21K
28726 C...SIGN OF MASSES I,J
28727             XMK=XMJ
28728             IF(IH.EQ.3) XMK=-XMK
28729             XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
28730             IDLAM(LKNT,1)=KFNCHI(IJ)
28731             IDLAM(LKNT,2)=ITH(IH)
28732             IDLAM(LKNT,3)=0
28733           ENDIF
28734   170   CONTINUE
28735   180 CONTINUE
28736
28737 C...CHI0_I -> CHI+_J + W-
28738       DO 220 IJ=1,2
28739         XMJ=SMW(IJ)
28740         AXMJ=ABS(XMJ)
28741         XMJ2=XMJ**2
28742         IF(AXMI.GE.AXMJ+XMW) THEN
28743           LKNT=LKNT+1
28744           GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28745           GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28746           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
28747           IDLAM(LKNT,1)=KFCCHI(IJ)
28748           IDLAM(LKNT,2)=-24
28749           IDLAM(LKNT,3)=0
28750           LKNT=LKNT+1
28751           XLAM(LKNT)=XLAM(LKNT-1)
28752           IDLAM(LKNT,1)=-KFCCHI(IJ)
28753           IDLAM(LKNT,2)=24
28754           IDLAM(LKNT,3)=0
28755         ELSEIF(AXMI.GE.AXMJ) THEN
28756           S12MIN=0D0
28757           S12MAX=(AXMI-AXMJ)**2
28758           XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2
28759           XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2
28760
28761 C...LEPTONS
28762           FID=11
28763           EI=KCHG(FID,1)/3D0
28764           T3=-0.5D0
28765           XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28766           FID=12
28767           EI=KCHG(FID,1)/3D0
28768           T3=0.5D0
28769           XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28770
28771           XXM(1)=0D0
28772           XXM(2)=XMJ
28773           XXM(3)=0D0
28774           XXM(4)=XMI
28775           XXM(9)=PMAS(24,1)
28776           XXM(10)=PMAS(24,2)
28777           XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
28778           XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
28779           IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190
28780           IF(XXM(11).LT.AXMI) THEN
28781             XXM(11)=1D6
28782           ELSEIF(XXM(12).LT.AXMI) THEN
28783             XXM(12)=1D6
28784           ENDIF
28785           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
28786             LKNT=LKNT+1
28787             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28788      &      PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28789             IDLAM(LKNT,1)=KFCCHI(IJ)
28790             IDLAM(LKNT,2)=11
28791             IDLAM(LKNT,3)=-12
28792             LKNT=LKNT+1
28793             XLAM(LKNT)=XLAM(LKNT-1)
28794             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28795             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28796             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28797             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
28798               LKNT=LKNT+1
28799               XLAM(LKNT)=XLAM(LKNT-1)
28800               IDLAM(LKNT,1)=KFCCHI(IJ)
28801               IDLAM(LKNT,2)=13
28802               IDLAM(LKNT,3)=-14
28803               LKNT=LKNT+1
28804               XLAM(LKNT)=XLAM(LKNT-1)
28805               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28806               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28807               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28808             ENDIF
28809           ENDIF
28810   190     CONTINUE
28811           IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
28812             XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
28813             XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28814           ELSE
28815             XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
28816             XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
28817           ENDIF
28818
28819           IF(XXM(11).LT.AXMI) THEN
28820             XXM(11)=1D6
28821           ENDIF
28822           IF(XXM(12).LT.AXMI) THEN
28823             XXM(12)=1D6
28824           ENDIF
28825           IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
28826             LKNT=LKNT+1
28827             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
28828      &      PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28829             XLAM(LKNT)=XLAM(LKNT-1)
28830             IDLAM(LKNT,1)=KFCCHI(IJ)
28831             IDLAM(LKNT,2)=15
28832             IDLAM(LKNT,3)=-16
28833             LKNT=LKNT+1
28834             XLAM(LKNT)=XLAM(LKNT-1)
28835             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28836             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28837             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28838           ENDIF
28839
28840 C...NOW, DO THE QUARKS
28841   200     CONTINUE
28842           FID=1
28843           EI=KCHG(FID,1)/3D0
28844           T3=-0.5D0
28845           XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1)
28846           FID=2
28847           EI=KCHG(FID,1)/3D0
28848           T3=0.5D0
28849           XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1)
28850
28851           XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
28852           XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
28853           IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210
28854           IF(XXM(11).LT.AXMI) THEN
28855             XXM(11)=1D6
28856           ELSEIF(XXM(12).LT.AXMI) THEN
28857             XXM(12)=1D6
28858           ENDIF
28859           IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
28860             LKNT=LKNT+1
28861             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
28862      &      PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
28863             IDLAM(LKNT,1)=KFCCHI(IJ)
28864             IDLAM(LKNT,2)=1
28865             IDLAM(LKNT,3)=-2
28866             LKNT=LKNT+1
28867             XLAM(LKNT)=XLAM(LKNT-1)
28868             IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28869             IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28870             IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28871             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
28872               LKNT=LKNT+1
28873               XLAM(LKNT)=XLAM(LKNT-1)
28874               IDLAM(LKNT,1)=KFCCHI(IJ)
28875               IDLAM(LKNT,2)=3
28876               IDLAM(LKNT,3)=-4
28877               LKNT=LKNT+1
28878               XLAM(LKNT)=XLAM(LKNT-1)
28879               IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28880               IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28881               IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28882             ENDIF
28883           ENDIF
28884   210     CONTINUE
28885         ENDIF
28886   220 CONTINUE
28887   230 CONTINUE
28888
28889 C...CHI0_I -> CHI+_I + H-
28890       DO 240 IJ=1,2
28891         XMJ=SMW(IJ)
28892         AXMJ=ABS(XMJ)
28893         XMJ2=XMJ**2
28894         XMHP=PMAS(ITHC,1)
28895         XMHP2=XMHP**2
28896         IF(AXMI.GE.AXMJ+XMHP) THEN
28897           LKNT=LKNT+1
28898           GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+
28899      &    ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2)
28900           GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+
28901      &    ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2)
28902           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
28903           IDLAM(LKNT,1)=KFCCHI(IJ)
28904           IDLAM(LKNT,2)=-ITHC
28905           IDLAM(LKNT,3)=0
28906           LKNT=LKNT+1
28907           XLAM(LKNT)=XLAM(LKNT-1)
28908           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28909           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28910           IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
28911         ELSE
28912
28913         ENDIF
28914   240 CONTINUE
28915
28916 C...2-BODY DECAYS TO FERMION SFERMION
28917       DO 250 J=1,16
28918         IF(J.GE.7.AND.J.LE.10) GOTO 250
28919         KF1=KSUSY1+J
28920         KF2=KSUSY2+J
28921         XMSF1=PMAS(PYCOMP(KF1),1)
28922         XMSF2=PMAS(PYCOMP(KF2),1)
28923         XMF=PMAS(J,1)
28924         IF(J.LE.6) THEN
28925           FCOL=3D0
28926         ELSE
28927           FCOL=1D0
28928         ENDIF
28929
28930         EI=KCHG(J,1)/3D0
28931         T3T=SIGN(1D0,EI)
28932         IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
28933         IF(MOD(J,2).EQ.0) THEN
28934           BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28935           AL=XMF*ZMIX(IX,4)/XMW/SBETA
28936           AR=-2D0*EI*TANW*ZMIX(IX,1)
28937           BR=AL
28938         ELSE
28939           BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T)
28940           AL=XMF*ZMIX(IX,3)/XMW/CBETA
28941           AR=-2D0*EI*TANW*ZMIX(IX,1)
28942           BR=AL
28943         ENDIF
28944
28945 C...D~ D_L
28946         IF(AXMI.GE.XMF+XMSF1) THEN
28947           LKNT=LKNT+1
28948           XMA2=XMSF1**2
28949           XMB2=XMF**2
28950           XL=PYLAMF(XMI2,XMA2,XMB2)
28951           CA=AL*SFMIX(J,1)+AR*SFMIX(J,2)
28952           CB=BL*SFMIX(J,1)+BR*SFMIX(J,2)
28953           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28954      &    (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28955           IDLAM(LKNT,1)=KF1
28956           IDLAM(LKNT,2)=-J
28957           IDLAM(LKNT,3)=0
28958           LKNT=LKNT+1
28959           XLAM(LKNT)=XLAM(LKNT-1)
28960           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28961           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28962           IDLAM(LKNT,3)=0
28963         ENDIF
28964
28965 C...D~ D_R
28966         IF(AXMI.GE.XMF+XMSF2) THEN
28967           LKNT=LKNT+1
28968           XMA2=XMSF2**2
28969           XMB2=XMF**2
28970           CA=AL*SFMIX(J,3)+AR*SFMIX(J,4)
28971           CB=BL*SFMIX(J,3)+BR*SFMIX(J,4)
28972           XL=PYLAMF(XMI2,XMA2,XMB2)
28973           XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
28974      &    (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
28975           IDLAM(LKNT,1)=KF2
28976           IDLAM(LKNT,2)=-J
28977           IDLAM(LKNT,3)=0
28978           LKNT=LKNT+1
28979           XLAM(LKNT)=XLAM(LKNT-1)
28980           IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
28981           IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
28982           IDLAM(LKNT,3)=0
28983         ENDIF
28984   250 CONTINUE
28985
28986 C...3-BODY DECAY TO Q Q~ GLUINO
28987       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
28988       IF(AXMI.GE.XMJ) THEN
28989         AXMJ=ABS(XMJ)
28990         XXM(1)=0D0
28991         XXM(2)=XMJ
28992         XXM(3)=0D0
28993         XXM(4)=XMI
28994         XXM(5)=PMAS(PYCOMP(KSUSY1+1),1)
28995         XXM(6)=PMAS(PYCOMP(KSUSY2+1),1)
28996         XXM(7)=1D6
28997         XXM(8)=0D0
28998         XXM(9)=0D0
28999         XXM(10)=0D0
29000         S12MIN=0D0
29001         S12MAX=(AXMI-AXMJ)**2
29002 C...ALL QUARKS BUT T
29003         XXM(11)=0D0
29004         XXM(12)=0D0
29005         XXM(13)=1D0
29006         XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29007         XXM(15)=1D0
29008         XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0)
29009         IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260
29010         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29011           LKNT=LKNT+1
29012           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29013      &    PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29014           IDLAM(LKNT,1)=KSUSY1+21
29015           IDLAM(LKNT,2)=1
29016           IDLAM(LKNT,3)=-1
29017           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29018             LKNT=LKNT+1
29019             XLAM(LKNT)=XLAM(LKNT-1)
29020             IDLAM(LKNT,1)=KSUSY1+21
29021             IDLAM(LKNT,2)=3
29022             IDLAM(LKNT,3)=-3
29023           ENDIF
29024         ENDIF
29025   260   CONTINUE
29026         IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
29027           XXM(5)=PMAS(PYCOMP(KSUSY1+5),1)
29028           XXM(6)=PMAS(PYCOMP(KSUSY2+5),1)
29029         ELSE
29030           XXM(6)=PMAS(PYCOMP(KSUSY1+5),1)
29031           XXM(5)=PMAS(PYCOMP(KSUSY2+5),1)
29032         ENDIF
29033         IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270
29034         IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29035           LKNT=LKNT+1
29036           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29037      &    PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29038           IDLAM(LKNT,1)=KSUSY1+21
29039           IDLAM(LKNT,2)=5
29040           IDLAM(LKNT,3)=-5
29041         ENDIF
29042 C...U-TYPE QUARKS
29043   270   CONTINUE
29044         XXM(5)=PMAS(PYCOMP(KSUSY1+2),1)
29045         XXM(6)=PMAS(PYCOMP(KSUSY2+2),1)
29046         XXM(13)=1D0
29047         XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0)
29048         XXM(15)=1D0
29049         XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0)
29050         IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280
29051         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29052           LKNT=LKNT+1
29053           XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
29054      &    PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)
29055           IDLAM(LKNT,1)=KSUSY1+21
29056           IDLAM(LKNT,2)=2
29057           IDLAM(LKNT,3)=-2
29058           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29059             LKNT=LKNT+1
29060             XLAM(LKNT)=XLAM(LKNT-1)
29061             IDLAM(LKNT,1)=KSUSY1+21
29062             IDLAM(LKNT,2)=4
29063             IDLAM(LKNT,3)=-4
29064           ENDIF
29065         ENDIF
29066   280   CONTINUE
29067       ENDIF
29068
29069   290 IKNT=LKNT
29070       XLAM(0)=0D0
29071       DO 300 I=1,IKNT
29072         IF(XLAM(I).LT.0D0) XLAM(I)=0D0
29073         XLAM(0)=XLAM(0)+XLAM(I)
29074   300 CONTINUE
29075       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
29076
29077       RETURN
29078       END
29079
29080 C*********************************************************************
29081
29082 *$ CREATE PYCJDC.FOR
29083 *COPY PYCJDC
29084 C...PYCJDC
29085 C...Calculate decay widths for the charginos (admixtures of
29086 C...charged Wino and charged Higgsino.
29087
29088 C...Input:  KCIN = KF code for particle
29089 C...Output: XLAM = widths
29090 C...        IDLAM = KF codes for decay particles
29091 C...        IKNT = number of decay channels defined
29092 C...AUTHOR: STEPHEN MRENNA
29093 C...Last change:
29094 C...10-16-95:  force decay chi^+_1 -> chi^0_1 e+ nu_e
29095 C...when CHIENU .NE. 0
29096
29097       SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
29098
29099 C...Double precision and integer declarations.
29100       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29101       INTEGER PYK,PYCHGE,PYCOMP
29102 C...Parameter statement to help give large particle numbers.
29103       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29104 C...Commonblocks.
29105       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29106       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29107       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29108       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29109      &SFMIX(16,4)
29110       COMMON/PYINTS/XXM(20)
29111       SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/
29112
29113 C...Local variables.
29114       INTEGER KFIN,KCIN
29115       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
29116      &XMZ,XMZ2,AXMJ,AXMI
29117       DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
29118       DOUBLE PRECISION S12MIN,S12MAX
29119       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK
29120       DOUBLE PRECISION PYLAMF,XL
29121       DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA
29122       DOUBLE PRECISION PYX2XH,PYX2XG
29123       DOUBLE PRECISION XLAM(0:200)
29124       INTEGER IDLAM(200,3)
29125       INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
29126       INTEGER ITH(3)
29127       INTEGER ITHC
29128       DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
29129       DOUBLE PRECISION SR2
29130       DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
29131
29132       DOUBLE PRECISION PYALEM,PI,PYALPS
29133       DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP
29134       DOUBLE PRECISION CA,CB,FCOL
29135       INTEGER KF1,KF2,ISF
29136       INTEGER KFNCHI(4),KFCCHI(2)
29137
29138       DOUBLE PRECISION TEMP
29139       DOUBLE PRECISION PYGAUS
29140       EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
29141       DOUBLE PRECISION PREC
29142       DATA ITH/25,35,36/
29143       DATA ITHC/37/
29144       DATA ETAH/1D0,1D0,-1D0/
29145       DATA SR2/1.4142136D0/
29146       DATA PI/3.141592654D0/
29147       DATA PREC/1D-2/
29148       DATA KFNCHI/1000022,1000023,1000025,1000035/
29149       DATA KFCCHI/1000024,1000037/
29150
29151 C...COUNT THE NUMBER OF DECAY MODES
29152       LKNT=0
29153       XMW=PMAS(24,1)
29154       XMW2=XMW**2
29155       XMZ=PMAS(23,1)
29156       XMZ2=XMZ**2
29157       XW=1D0-XMW2/XMZ2
29158       TANW = SQRT(XW/(1D0-XW))
29159
29160 C...1 OR 2 DEPENDING ON CHARGINO TYPE
29161       IX=1
29162       IF(KFIN.EQ.KFCCHI(2)) IX=2
29163       KCIN=PYCOMP(KFIN)
29164
29165       XMI=SMW(IX)
29166       XMI2=XMI**2
29167       AXMI=ABS(XMI)
29168       AEM=PYALEM(XMI2)
29169       AS =PYALPS(XMI2)
29170       C1=AEM/XW
29171       XMI3=ABS(XMI**3)
29172       TANB=RMSS(5)
29173       BETA=ATAN(TANB)
29174       CBETA=COS(BETA)
29175       SBETA=TANB*CBETA
29176       ALFA=RMSS(18)
29177
29178 C...GRAVITINO DECAY MODES
29179
29180       IF(IMSS(11).EQ.1) THEN
29181         XMP=RMSS(28)
29182         IDG=39+KSUSY1
29183         XMGR=PMAS(PYCOMP(IDG),1)
29184         SINW=SQRT(XW)
29185         COSW=SQRT(1D0-XW)
29186         XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
29187         IF(AXMI.GT.XMGR+XMW) THEN
29188           LKNT=LKNT+1
29189           IDLAM(LKNT,1)=IDG
29190           IDLAM(LKNT,2)=24
29191           IDLAM(LKNT,3)=0
29192           XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+
29193      &  .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))*
29194      &  (1D0-XMW2/XMI2)**4
29195         ENDIF
29196         IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
29197           LKNT=LKNT+1
29198           IDLAM(LKNT,1)=IDG
29199           IDLAM(LKNT,2)=37
29200           IDLAM(LKNT,3)=0
29201           XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+
29202      &   (UMIX(IX,2)*SBETA)**2))
29203      &   *(1D0-PMAS(37,1)**2/XMI2)**4
29204        ENDIF
29205       ENDIF
29206
29207 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
29208       IF(IX.EQ.1) GOTO 150
29209       XMJ=SMW(1)
29210       AXMJ=ABS(XMJ)
29211       XMJ2=XMJ**2
29212
29213 C...CHI_2+ -> CHI_1+ + Z0
29214       IF(AXMI.GE.AXMJ+XMZ) THEN
29215         LKNT=LKNT+1
29216         GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)
29217         GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)
29218         XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR)
29219         IDLAM(LKNT,1)=KFCCHI(1)
29220         IDLAM(LKNT,2)=23
29221         IDLAM(LKNT,3)=0
29222
29223 C...CHARGED LEPTONS
29224       ELSEIF(AXMI.GE.AXMJ) THEN
29225         XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2))
29226         XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2))
29227         XXM(9)=XMZ
29228         XXM(10)=PMAS(23,2)
29229         XXM(1)=0D0
29230         XXM(2)=XMJ
29231         XXM(3)=0D0
29232         XXM(4)=XMI
29233         S12MIN=0D0
29234         S12MAX=(AXMJ-AXMI)**2
29235         XXM(7)= (-0.5D0+XW)/(1D0-XW)
29236         XXM(8)= XW/(1D0-XW)
29237         XXM(11)=PMAS(PYCOMP(KSUSY1+12),1)
29238         XXM(12)=VMIX(2,1)*VMIX(1,1)
29239         IF( XXM(11).LT.AXMI ) THEN
29240           XXM(11)=1D6
29241         ENDIF
29242         IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
29243           LKNT=LKNT+1
29244           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29245      &    PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29246           IDLAM(LKNT,1)=KFCCHI(1)
29247           IDLAM(LKNT,2)=11
29248           IDLAM(LKNT,3)=-11
29249           IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
29250             LKNT=LKNT+1
29251             XLAM(LKNT)=XLAM(LKNT-1)
29252             IDLAM(LKNT,1)=KFCCHI(1)
29253             IDLAM(LKNT,2)=13
29254             IDLAM(LKNT,3)=-13
29255             IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
29256               LKNT=LKNT+1
29257               XLAM(LKNT)=XLAM(LKNT-1)
29258               IDLAM(LKNT,1)=KFCCHI(1)
29259               IDLAM(LKNT,2)=15
29260               IDLAM(LKNT,3)=-15
29261             ENDIF
29262           ENDIF
29263         ENDIF
29264
29265 C...NEUTRINOS
29266   100   CONTINUE
29267         XXM(7)= (0.5D0)/(1D0-XW)
29268         XXM(8)= 0D0
29269         XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29270         XXM(12)=UMIX(2,1)*UMIX(1,1)
29271         IF( XXM(11).LT.AXMI ) THEN
29272           XXM(11)=1D6
29273         ENDIF
29274         IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
29275           LKNT=LKNT+1
29276           XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
29277      &    PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29278           IDLAM(LKNT,1)=KFCCHI(1)
29279           IDLAM(LKNT,2)=12
29280           IDLAM(LKNT,3)=-12
29281           LKNT=LKNT+1
29282           XLAM(LKNT)=XLAM(LKNT-1)
29283           IDLAM(LKNT,1)=KFCCHI(1)
29284           IDLAM(LKNT,2)=14
29285           IDLAM(LKNT,3)=-14
29286           LKNT=LKNT+1
29287           XLAM(LKNT)=XLAM(LKNT-1)
29288           IDLAM(LKNT,1)=KFCCHI(1)
29289           IDLAM(LKNT,2)=16
29290           IDLAM(LKNT,3)=-16
29291         ENDIF
29292
29293 C...D-TYPE QUARKS
29294   110   CONTINUE
29295         XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW)
29296         XXM(8)= XW/3D0/(1D0-XW)
29297         XXM(11)=PMAS(PYCOMP(KSUSY1+2),1)
29298         XXM(12)=VMIX(2,1)*VMIX(1,1)
29299         IF( XXM(11).LT.AXMI ) GOTO 120
29300         IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
29301           LKNT=LKNT+1
29302           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29303      &    PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29304           IDLAM(LKNT,1)=KFCCHI(1)
29305           IDLAM(LKNT,2)=1
29306           IDLAM(LKNT,3)=-1
29307           IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
29308             LKNT=LKNT+1
29309             XLAM(LKNT)=XLAM(LKNT-1)
29310             IDLAM(LKNT,1)=KFCCHI(1)
29311             IDLAM(LKNT,2)=3
29312             IDLAM(LKNT,3)=-3
29313             IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
29314               LKNT=LKNT+1
29315               XLAM(LKNT)=XLAM(LKNT-1)
29316               IDLAM(LKNT,1)=KFCCHI(1)
29317               IDLAM(LKNT,2)=5
29318               IDLAM(LKNT,3)=-5
29319             ENDIF
29320           ENDIF
29321         ENDIF
29322
29323 C...U-TYPE QUARKS
29324   120   CONTINUE
29325         XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW)
29326         XXM(8)= -2D0*XW/3D0/(1D0-XW)
29327         XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29328         XXM(12)=UMIX(2,1)*UMIX(1,1)
29329         IF( XXM(11).LT.AXMI ) GOTO 130
29330         IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
29331           LKNT=LKNT+1
29332           XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29333      &    PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC)
29334           IDLAM(LKNT,1)=KFCCHI(1)
29335           IDLAM(LKNT,2)=2
29336           IDLAM(LKNT,3)=-2
29337           IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
29338             LKNT=LKNT+1
29339             XLAM(LKNT)=XLAM(LKNT-1)
29340             IDLAM(LKNT,1)=KFCCHI(1)
29341             IDLAM(LKNT,2)=4
29342             IDLAM(LKNT,3)=-4
29343           ENDIF
29344         ENDIF
29345   130   CONTINUE
29346       ENDIF
29347
29348 C...CHI_2+ -> CHI_1+ + H0_K
29349       EH(2)=COS(ALFA)
29350       EH(1)=SIN(ALFA)
29351       EH(3)=-SBETA
29352       DH(2)=-SIN(ALFA)
29353       DH(1)=COS(ALFA)
29354       DH(3)=COS(BETA)
29355       DO 140 IH=1,3
29356         XMH=PMAS(ITH(IH),1)
29357         XMH2=XMH**2
29358 C...NO 3-BODY OPTION
29359         IF(AXMI.GE.AXMJ+XMH) THEN
29360           LKNT=LKNT+1
29361           XL=PYLAMF(XMI2,XMJ2,XMH2)
29362           F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) -
29363      &    VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2
29364           F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) -
29365      &    VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2
29366           XMK=XMJ*ETAH(IH)
29367           XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K)
29368           IDLAM(LKNT,1)=KFCCHI(1)
29369           IDLAM(LKNT,2)=ITH(IH)
29370           IDLAM(LKNT,3)=0
29371         ENDIF
29372   140 CONTINUE
29373
29374 C...CHI1 JUMPS TO HERE
29375   150 CONTINUE
29376
29377 C...CHI+_I -> CHI0_J + W+
29378       DO 180 IJ=1,4
29379         XMJ=SMZ(IJ)
29380         AXMJ=ABS(XMJ)
29381         XMJ2=XMJ**2
29382         IF(AXMI.GE.AXMJ+XMW) THEN
29383           LKNT=LKNT+1
29384           GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2
29385           GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2
29386           XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR)
29387           IDLAM(LKNT,1)=KFNCHI(IJ)
29388           IDLAM(LKNT,2)=24
29389           IDLAM(LKNT,3)=0
29390
29391 C...LEPTONS
29392         ELSEIF(AXMI.GE.AXMJ) THEN
29393           XMF1=0D0
29394           XMF2=0D0
29395           S12MIN=(XMF1+XMF2)**2
29396           S12MAX=(AXMJ-AXMI)**2
29397           XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1)
29398           XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1)
29399           FID=11
29400           EI=KCHG(FID,1)/3D0
29401           T3=-0.5D0
29402           XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29403           FID=12
29404           EI=KCHG(FID,1)/3D0
29405           T3=0.5D0
29406           XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29407
29408           XXM(4)=XMI
29409           XXM(1)=XMF1
29410           XXM(2)=XMJ
29411           XXM(3)=XMF2
29412           XXM(9)=PMAS(24,1)
29413           XXM(10)=PMAS(24,2)
29414           XXM(11)=PMAS(PYCOMP(KSUSY1+11),1)
29415           XXM(12)=PMAS(PYCOMP(KSUSY1+12),1)
29416
29417 C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
29418 C...--> 1/(16PI)/M**3*(AEM/XW)**2
29419
29420           IF(XXM(11).LT.AXMI) THEN
29421             XXM(11)=1D6
29422           ENDIF
29423           IF(XXM(12).LT.AXMI) THEN
29424             XXM(12)=1D6
29425           ENDIF
29426           IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
29427             LKNT=LKNT+1
29428             TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29429             XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29430             IDLAM(LKNT,1)=KFNCHI(IJ)
29431             IDLAM(LKNT,2)=-11
29432             IDLAM(LKNT,3)=12
29433
29434 C...ONLY DECAY CHI+1 -> E+ NU_E
29435             IF( IMSS(12).NE. 0 ) GOTO 220
29436             IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
29437               LKNT=LKNT+1
29438               XXM(11)=PMAS(PYCOMP(KSUSY1+13),1)
29439               XXM(12)=PMAS(PYCOMP(KSUSY1+14),1)
29440               IF(XXM(11).LT.AXMI) THEN
29441                 XXM(11)=1D6
29442               ELSEIF(XXM(12).LT.AXMI) THEN
29443                 XXM(12)=1D6
29444               ENDIF
29445               TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29446               XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29447               IDLAM(LKNT,1)=KFNCHI(IJ)
29448               IDLAM(LKNT,2)=-13
29449               IDLAM(LKNT,3)=14
29450               IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
29451                 LKNT=LKNT+1
29452                 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
29453                   XXM(11)=PMAS(PYCOMP(KSUSY1+15),1)
29454                 ELSE
29455                   XXM(11)=PMAS(PYCOMP(KSUSY2+15),1)
29456                 ENDIF
29457                 XXM(12)=PMAS(PYCOMP(KSUSY1+16),1)
29458                 IF(XXM(11).LT.AXMI) THEN
29459                   XXM(11)=1D6
29460                 ENDIF
29461                 IF(XXM(12).LT.AXMI) THEN
29462                   XXM(12)=1D6
29463                 ENDIF
29464                 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29465                 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
29466                 IDLAM(LKNT,1)=KFNCHI(IJ)
29467                 IDLAM(LKNT,2)=-15
29468                 IDLAM(LKNT,3)=16
29469               ENDIF
29470             ENDIF
29471           ENDIF
29472
29473 C...NOW, DO THE QUARKS
29474   160     CONTINUE
29475           FID=1
29476           EI=KCHG(FID,1)/3D0
29477           T3=-0.5D0
29478           XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1)
29479           FID=1
29480           EI=KCHG(FID,1)/3D0
29481           T3=0.5D0
29482           XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1)
29483
29484           XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29485           XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29486           IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170
29487           IF(XXM(11).LT.AXMI) THEN
29488             XXM(11)=1D6
29489           ELSEIF(XXM(12).LT.AXMI) THEN
29490             XXM(12)=1D6
29491           ENDIF
29492           IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29493             LKNT=LKNT+1
29494             XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
29495      &      PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29496             IDLAM(LKNT,1)=KFNCHI(IJ)
29497             IDLAM(LKNT,2)=-1
29498             IDLAM(LKNT,3)=2
29499             IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29500               LKNT=LKNT+1
29501               XLAM(LKNT)=XLAM(LKNT-1)
29502               IDLAM(LKNT,1)=KFNCHI(IJ)
29503               IDLAM(LKNT,2)=-3
29504               IDLAM(LKNT,3)=4
29505             ENDIF
29506           ENDIF
29507   170     CONTINUE
29508         ENDIF
29509   180 CONTINUE
29510
29511 C...CHI+_I -> CHI0_J + H+
29512       DO 190 IJ=1,4
29513         XMJ=SMZ(IJ)
29514         AXMJ=ABS(XMJ)
29515         XMJ2=XMJ**2
29516         XMHP=PMAS(ITHC,1)
29517         XMHP2=XMHP**2
29518         IF(AXMI.GE.AXMJ+XMHP) THEN
29519           LKNT=LKNT+1
29520           GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+
29521      &    ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2)
29522           GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+
29523      &    ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2)
29524           XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR)
29525           IDLAM(LKNT,1)=KFNCHI(IJ)
29526           IDLAM(LKNT,2)=ITHC
29527           IDLAM(LKNT,3)=0
29528         ELSE
29529
29530         ENDIF
29531   190 CONTINUE
29532
29533 C...2-BODY DECAYS TO FERMION SFERMION
29534       DO 200 J=1,16
29535         IF(J.GE.7.AND.J.LE.10) GOTO 200
29536         IF(MOD(J,2).EQ.0) THEN
29537           KF1=KSUSY1+J-1
29538         ELSE
29539           KF1=KSUSY1+J+1
29540         ENDIF
29541         KF2=KF1+KSUSY1
29542         XMSF1=PMAS(PYCOMP(KF1),1)
29543         XMSF2=PMAS(PYCOMP(KF2),1)
29544         XMF=PMAS(J,1)
29545         IF(J.LE.6) THEN
29546           FCOL=3D0
29547         ELSE
29548           FCOL=1D0
29549         ENDIF
29550
29551 C...U~ D_L
29552         IF(MOD(J,2).EQ.0) THEN
29553           XMFP=PMAS(J-1,1)
29554           AL=UMIX(IX,1)
29555           BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2
29556           AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2
29557           BR=0D0
29558           ISF=J-1
29559         ELSE
29560           XMFP=PMAS(J+1,1)
29561           AL=VMIX(IX,1)
29562           BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2
29563           BR=0D0
29564           AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2
29565           ISF=J+1
29566         ENDIF
29567
29568 C...~U_L D
29569         IF(AXMI.GE.XMF+XMSF1) THEN
29570           LKNT=LKNT+1
29571           XMA2=XMSF1**2
29572           XMB2=XMF**2
29573           XL=PYLAMF(XMI2,XMA2,XMB2)
29574           CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2)
29575           CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2)
29576           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29577      &    (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29578           IDLAM(LKNT,3)=0
29579           IF(MOD(J,2).EQ.0) THEN
29580             IDLAM(LKNT,1)=-KF1
29581             IDLAM(LKNT,2)=J
29582           ELSE
29583             IDLAM(LKNT,1)=KF1
29584             IDLAM(LKNT,2)=-J
29585           ENDIF
29586         ENDIF
29587
29588 C...U~ D_R
29589         IF(AXMI.GE.XMF+XMSF2) THEN
29590           LKNT=LKNT+1
29591           XMA2=XMSF2**2
29592           XMB2=XMF**2
29593           CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4)
29594           CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4)
29595           XL=PYLAMF(XMI2,XMA2,XMB2)
29596           XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
29597      &    (CA**2+CB**2)+4D0*CA*CB*XMF*XMI)
29598           IDLAM(LKNT,3)=0
29599           IF(MOD(J,2).EQ.0) THEN
29600             IDLAM(LKNT,1)=-KF2
29601             IDLAM(LKNT,2)=J
29602           ELSE
29603             IDLAM(LKNT,1)=KF2
29604             IDLAM(LKNT,2)=-J
29605           ENDIF
29606         ENDIF
29607   200 CONTINUE
29608
29609 C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
29610 C...A 2-BODY -- 2-BODY CHAIN
29611       XMJ=PMAS(PYCOMP(KSUSY1+21),1)
29612       IF(AXMI.GE.XMJ) THEN
29613         AXMJ=ABS(XMJ)
29614         S12MIN=0D0
29615         S12MAX=(AXMI-AXMJ)**2
29616         XXM(1)=0D0
29617         XXM(2)=XMJ
29618         XXM(3)=0D0
29619         XXM(4)=XMI
29620         XXM(5)=0D0
29621         XXM(6)=0D0
29622         XXM(9)=1D6
29623         XXM(10)=0D0
29624         XXM(7)=UMIX(IX,1)*SR2
29625         XXM(8)=VMIX(IX,1)*SR2
29626         XXM(11)=PMAS(PYCOMP(KSUSY1+1),1)
29627         XXM(12)=PMAS(PYCOMP(KSUSY1+2),1)
29628         IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210
29629         IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
29630           LKNT=LKNT+1
29631           XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
29632      &    PYGAUS(PYXXW5,S12MIN,S12MAX,PREC)
29633           IDLAM(LKNT,1)=KSUSY1+21
29634           IDLAM(LKNT,2)=-1
29635           IDLAM(LKNT,3)=2
29636           IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
29637             LKNT=LKNT+1
29638             XLAM(LKNT)=XLAM(LKNT-1)
29639             IDLAM(LKNT,1)=KSUSY1+21
29640             IDLAM(LKNT,2)=-3
29641             IDLAM(LKNT,3)=4
29642           ENDIF
29643         ENDIF
29644   210   CONTINUE
29645       ENDIF
29646
29647   220 IKNT=LKNT
29648       XLAM(0)=0D0
29649       DO 230 I=1,IKNT
29650         XLAM(0)=XLAM(0)+XLAM(I)
29651         IF(XLAM(I).LT.0D0) THEN
29652           WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
29653      &    (IDLAM(I,J),J=1,3)
29654           XLAM(I)=0D0
29655         ENDIF
29656   230 CONTINUE
29657       IF(XLAM(0).EQ.0D0) THEN
29658         XLAM(0)=1D-6
29659         WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
29660         WRITE(MSTU(11),*) LKNT
29661         WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
29662       ENDIF
29663
29664       RETURN
29665       END
29666
29667 C*********************************************************************
29668
29669 *$ CREATE PYXXZ5.FOR
29670 *COPY PYXXZ5
29671 C...PYXXZ5
29672 C...Calculates chi0 -> chi0 + f + ~f.
29673
29674       FUNCTION PYXXZ5(X)
29675
29676 C...Double precision and integer declarations.
29677       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29678       INTEGER PYK,PYCHGE,PYCOMP
29679 C...Parameter statement to help give large particle numbers.
29680       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29681 C...Commonblocks.
29682       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29683       COMMON/PYINTS/XXM(20)
29684       SAVE /PYDAT1/,/PYINTS/
29685
29686 C...Local variables.
29687       DOUBLE PRECISION PYXXZ5,X
29688       DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2
29689       DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
29690       DOUBLE PRECISION SIJ
29691       DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD
29692       DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ
29693       DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29694       INTEGER I
29695       DATA SR2/1.4142136D0/
29696
29697 C...Statement functions.
29698 C...Integral from x to y of (t-a)(b-t) dt.
29699       TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29700 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29701       TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29702      &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29703 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29704       TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29705      &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29706 C...Integral from x to y of (t-a)/(b-t) dt.
29707       UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29708 C...Integral from x to y of 1/(t-a) dt.
29709       TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29710
29711       XM12=XXM(1)**2
29712       XM22=XXM(2)**2
29713       XM32=XXM(3)**2
29714       S=XXM(4)**2
29715       S13=X
29716
29717       S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29718       S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29719      &( (X-XM22-S)**2  -4D0*XM22*S  ) )
29720
29721       S23MIN=(S23AVE-S23DEL)
29722       S23MAX=(S23AVE+S23DEL)
29723
29724       XMV=XXM(7)
29725       XMG=XXM(8)
29726       XMSD=XXM(5)**2
29727       XMSU=XXM(6)**2
29728       OL=XXM(9)
29729       OR=XXM(10)
29730       OL2=OL**2
29731       OR2=OR**2
29732       LE=XXM(11)
29733       RE=XXM(12)
29734       LE2=LE**2
29735       RE2=RE**2
29736       FLI=XXM(13)
29737       FLJ=XXM(14)
29738       FRI=XXM(15)
29739       FRJ=XXM(16)
29740
29741       WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
29742       SIJ=2D0*XXM(2)*XXM(4)*S13
29743
29744       IF(XMV.LE.1000D0) THEN
29745         WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S)
29746      &  +SIJ*(S23MAX-S23MIN) )/WPROP2
29747         IF(XXM(5).LE.10000D0) THEN
29748           WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29749      &    + SIJ*TPROP(S23MAX,S23MIN,XMSD) )
29750           WFL1=WFL1*(S13-XMV**2)/WPROP2
29751         ELSE
29752           WFL1=0D0
29753         ENDIF
29754         IF(XXM(6).LE.10000D0) THEN
29755           WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29756      &    + SIJ*TPROP(S23MAX,S23MIN,XMSU) )
29757           WFL2=WFL2*(S13-XMV**2)/WPROP2
29758         ELSE
29759           WFL2=0D0
29760         ENDIF
29761       ELSE
29762         WW=0D0
29763         WFL1=0D0
29764         WFL2=0D0
29765       ENDIF
29766       IF(XXM(5).LE.10000D0) THEN
29767         WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29768      &  + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) )
29769       ELSE
29770         WF1=0D0
29771       ENDIF
29772       IF(XXM(6).LE.10000D0) THEN
29773         WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29774      &  + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) )
29775       ELSE
29776         WF2=0D0
29777       ENDIF
29778
29779 C...WFL1=0.0
29780 C...WFL2=0.0
29781       PYXXZ5=(WW+WF1+WF2+WFL1+WFL2)
29782       IF(PYXXZ5.LT.0D0) THEN
29783         WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 '
29784         WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4)
29785         WRITE(MSTU(11),*) (XXM(I),I=5,8)
29786         WRITE(MSTU(11),*) (XXM(I),I=9,12)
29787         WRITE(MSTU(11),*) (XXM(I),I=13,16)
29788         WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
29789         WRITE(MSTU(11),*) S23MIN,S23MAX
29790         PYXXZ5=0D0
29791       ENDIF
29792
29793       RETURN
29794       END
29795
29796 C*********************************************************************
29797
29798 *$ CREATE PYXXW5.FOR
29799 *COPY PYXXW5
29800 C...PYXXW5
29801 C...Calculates chi0(+) -> chi+(0) + f + ~f'.
29802
29803       FUNCTION PYXXW5(X)
29804
29805 C...Double precision and integer declarations.
29806       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29807       INTEGER PYK,PYCHGE,PYCOMP
29808 C...Parameter statement to help give large particle numbers.
29809       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
29810 C...Commonblocks.
29811       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29812       COMMON/PYINTS/XXM(20)
29813       SAVE /PYDAT1/,/PYINTS/
29814
29815 C...Local variables.
29816       DOUBLE PRECISION PYXXW5,X
29817       DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
29818       DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
29819       DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU
29820       DOUBLE PRECISION SIJ
29821       DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
29822       INTEGER IK
29823       SAVE IK
29824       DATA IK/0/
29825       DATA SR2/1.4142136D0/
29826
29827 C...Statement functions.
29828 C...Integral from x to y of (t-a)(b-t) dt.
29829       TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
29830 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
29831       TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
29832      &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
29833 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
29834       TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
29835      &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
29836 C...Integral from x to y of (t-a)/(b-t) dt.
29837       UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
29838 C...Integral from x to y of 1/(t-a) dt.
29839       TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
29840
29841       XM12=XXM(1)**2
29842       XM22=XXM(2)**2
29843       XM32=XXM(3)**2
29844       S=XXM(4)**2
29845       S13=X
29846       IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
29847         S23AVE=0.5D0*(XM22+S-S13)
29848         S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
29849       ELSE
29850         S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
29851         S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
29852      &  ( (X-XM22-S)**2  -4D0*XM22*S  ) )
29853       ENDIF
29854       S23MIN=(S23AVE-S23DEL)
29855       S23MAX=(S23AVE+S23DEL)
29856       IF(S23DEL.LT.1D-3) THEN
29857         PYXXW5=0D0
29858         RETURN
29859       ENDIF
29860       XMV=XXM(9)
29861       XMG=XXM(10)
29862       XMSD=XXM(11)**2
29863       XMSU=XXM(12)**2
29864       OL=XXM(5)
29865       OR=XXM(6)
29866       FLD=XXM(7)
29867       FLU=XXM(8)
29868
29869       WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2)
29870       SIJ=S13*XXM(2)*XXM(4)
29871       IF(XMV.LE.1000D0) THEN
29872         WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S)
29873      &  -2D0*OL*OR*SIJ*(S23MAX-S23MIN)
29874         WW=WW/WPROP2
29875         IF(XXM(11).LE.10000D0) THEN
29876           WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD)
29877      &    -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD)
29878           WWD=-WWD*SR2*FLD
29879           WWD=WWD*(S13-XMV**2)/WPROP2
29880         ELSE
29881           WWD=0D0
29882         ENDIF
29883         IF(XXM(12).LE.10000D0) THEN
29884           WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU)
29885      &    -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU)
29886           WWU=WWU*SR2*FLU
29887           WWU=WWU*(S13-XMV**2)/WPROP2
29888         ELSE
29889           WWU=0D0
29890         ENDIF
29891       ELSE
29892         WW=0D0
29893         WWD=0D0
29894         WWU=0D0
29895       ENDIF
29896       IF(XXM(12).LE.10000D0) THEN
29897         WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU)
29898       ELSE
29899         WU=0D0
29900       ENDIF
29901       IF(XXM(11).LE.10000D0) THEN
29902         WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD)
29903       ELSE
29904         WD=0D0
29905       ENDIF
29906       IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN
29907         WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU)
29908       ELSE
29909         WUD=0D0
29910       ENDIF
29911
29912       PYXXW5=WW+WU+WD+WWU+WWD+WUD
29913
29914       IF(PYXXW5.LT.0D0) THEN
29915         IF(IK.EQ.0) THEN
29916           WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 '
29917           WRITE(MSTU(11),*) WW,WU,WD
29918           WRITE(MSTU(11),*) WWD,WWU,WUD
29919           WRITE(MSTU(11),*) SQRT(S13)
29920           WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S)
29921           IK=1
29922         ENDIF
29923         PYXXW5=0D0
29924       ENDIF
29925
29926       RETURN
29927       END
29928
29929 C*********************************************************************
29930
29931 *$ CREATE PYXXGA.FOR
29932 *COPY PYXXGA
29933 C...PYXXGA
29934 C...Calculates chi0_i -> chi0_j + gamma.
29935
29936       FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
29937
29938 C...Double precision and integer declarations.
29939       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29940       INTEGER PYK,PYCHGE,PYCOMP
29941
29942 C...Local variables.
29943       DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
29944       DOUBLE PRECISION F1,F2
29945
29946       F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
29947       F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
29948       PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
29949       PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
29950
29951       RETURN
29952       END
29953
29954 C*********************************************************************
29955
29956 *$ CREATE PYX2XG.FOR
29957 *COPY PYX2XG
29958 C...PYX2XG
29959 C...Calculates the decay rate for ino -> ino + gauge boson.
29960
29961       FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
29962
29963 C...Double precision and integer declarations.
29964       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29965       INTEGER PYK,PYCHGE,PYCOMP
29966
29967 C...Local variables.
29968       DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR
29969       DOUBLE PRECISION XL,PYLAMF,C1
29970       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
29971
29972       XMI2=XM1**2
29973       XMI3=ABS(XM1**3)
29974       XMJ2=XM2**2
29975       XMV2=XM3**2
29976       XL=PYLAMF(XMI2,XMJ2,XMV2)
29977       PYX2XG=C1/8D0/XMI3*SQRT(XL)
29978      &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
29979      &12D0*GL*GR*XM1*XM2*XMV2)
29980
29981       RETURN
29982       END
29983
29984 C*********************************************************************
29985
29986 *$ CREATE PYX2XH.FOR
29987 *COPY PYX2XH
29988 C...PYX2XH
29989 C...Calculates the decay rate for ino -> ino + H.
29990
29991       FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR)
29992
29993 C...Double precision and integer declarations.
29994       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29995       INTEGER PYK,PYCHGE,PYCOMP
29996
29997 C...Local variables.
29998       DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR
29999       DOUBLE PRECISION XL,PYLAMF,C1
30000       DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
30001
30002       XMI2=XM1**2
30003       XMI3=ABS(XM1**3)
30004       XMJ2=XM2**2
30005       XMV2=XM3**2
30006       XL=PYLAMF(XMI2,XMJ2,XMV2)
30007       PYX2XH=C1/8D0/XMI3*SQRT(XL)
30008      &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+
30009      &4D0*GL*GR*XM1*XM2)
30010
30011       RETURN
30012       END
30013
30014 C*********************************************************************
30015
30016 *$ CREATE PYXXZ2.FOR
30017 *COPY PYXXZ2
30018 C...PYXXZ2
30019 C...Calculates chi+ -> chi+ + f + ~f.
30020
30021       FUNCTION PYXXZ2(X)
30022
30023 C...Double precision and integer declarations.
30024       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30025       INTEGER PYK,PYCHGE,PYCOMP
30026 C...Parameter statement to help give large particle numbers.
30027       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30028 C...Commonblocks.
30029       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30030       COMMON/PYINTS/XXM(20)
30031       SAVE /PYDAT1/,/PYINTS/
30032
30033 C...Local variables.
30034       DOUBLE PRECISION PYXXZ2,X
30035       DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2
30036       DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD
30037       DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL
30038       DOUBLE PRECISION SIJ
30039       DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT
30040       DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
30041       INTEGER I
30042       DATA SR2/1.4142136D0/
30043
30044 C...Statement functions.
30045 C...Integral from x to y of (t-a)(b-t) dt.
30046       TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
30047 C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
30048       TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
30049      &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
30050 C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
30051       TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
30052      &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
30053 C...Integral from x to y of 1/(t-a) dt.
30054       TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
30055
30056       XM12=XXM(1)**2
30057       XM22=XXM(2)**2
30058       XM32=XXM(3)**2
30059       S=XXM(4)**2
30060       S13=X
30061       IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN
30062         S23AVE=0.5D0*(XM22+S-S13)
30063         S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S )
30064       ELSE
30065         S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
30066         S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
30067      &  ( (X-XM22-S)**2  -4D0*XM22*S  ) )
30068       ENDIF
30069       S23MIN=(S23AVE-S23DEL)
30070       S23MAX=(S23AVE+S23DEL)
30071       IF(S23DEL.LT.1D-3) THEN
30072         PYXXZ2=0D0
30073         RETURN
30074       ENDIF
30075
30076       XMV=XXM(9)
30077       XMG=XXM(10)
30078       XMSL=XXM(11)**2
30079       OL=XXM(5)
30080       OR=XXM(6)
30081       OL2=OL**2
30082       OR2=OR**2
30083       LE=XXM(7)
30084       RE=XXM(8)
30085       LE2=LE**2
30086       RE2=RE**2
30087       CT=XXM(12)
30088
30089       WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
30090       SIJ=XXM(2)*XXM(4)*S13
30091       WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S)
30092      &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN)
30093       WW=WW/WPROP2
30094       IF(XMSL.GT.1D4*S) THEN
30095         WD=0D0
30096         WWD=0D0
30097       ELSE
30098         WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL)
30099         WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)-
30100      &  OR*SIJ*TPROP(S23MAX,S23MIN,XMSL)
30101         WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2
30102       ENDIF
30103
30104       PYXXZ2=(WW+WD+WWD)
30105       IF(PYXXZ2.LT.0D0) THEN
30106         WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 '
30107         WRITE(MSTU(11),*) WW,WD,WWD
30108         WRITE(MSTU(11),*) S23MIN,S23MAX
30109         WRITE(MSTU(11),*) (XXM(I),I=1,4)
30110         WRITE(MSTU(11),*) (XXM(I),I=5,8)
30111         WRITE(MSTU(11),*) (XXM(I),I=9,12)
30112         PYXXZ2=0D0
30113       ENDIF
30114
30115       RETURN
30116       END
30117
30118 C*********************************************************************
30119
30120 *$ CREATE PYHEXT.FOR
30121 *COPY PYHEXT
30122 C...PYHEXT
30123 C...Calculates the non-standard decay modes of the Higgs boson.
30124
30125       SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
30126
30127 C...Double precision and integer declarations.
30128       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30129       INTEGER PYK,PYCHGE,PYCOMP
30130 C...Parameter statement to help give large particle numbers.
30131       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30132 C...Commonblocks.
30133       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30134       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30135       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30136       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
30137       COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
30138      &SFMIX(16,4)
30139       SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
30140
30141 C...Local variables.
30142       INTEGER KFIN
30143       DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
30144      &XMZ,XMZ2,AXMJ,AXMI
30145       DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG
30146       DOUBLE PRECISION S12MIN,S12MAX
30147       DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2
30148       DOUBLE PRECISION PYLAMF,XL,CF,EI
30149       INTEGER IDU,IC,ILR,IFL
30150       DOUBLE PRECISION TANW,XW,AEM,C1,AS
30151       DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
30152       DOUBLE PRECISION XLAM(0:200)
30153       INTEGER IDLAM(200,3)
30154       INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK
30155       INTEGER ITH(4)
30156       INTEGER KFNCHI(4),KFCCHI(2)
30157       DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
30158       DOUBLE PRECISION SR2
30159       DOUBLE PRECISION BETA,ALFA
30160       DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB
30161       DOUBLE PRECISION PYALEM,PI,PYALPS
30162       DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR
30163       DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML
30164       DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
30165       DOUBLE PRECISION XMJL,XMJR,XM1,XM2
30166       DATA ITH/25,35,36,37/
30167       DATA ETAH/1D0,1D0,-1D0/
30168       DATA SR2/1.4142136D0/
30169       DATA PI/3.141592654D0/
30170       DATA KFNCHI/1000022,1000023,1000025,1000035/
30171       DATA KFCCHI/1000024,1000037/
30172
30173 C...COUNT THE NUMBER OF DECAY MODES
30174       LKNT=IKNT
30175
30176       XMW=PMAS(24,1)
30177       XMW2=XMW**2
30178       XMZ=PMAS(23,1)
30179       XMZ2=XMZ**2
30180       XW=PARU(102)
30181       TANW = SQRT(XW/(1D0-XW))
30182       CW=SQRT(1D0-XW)
30183
30184 C...1 - 4 DEPENDING ON Higgs species.
30185       IH=1
30186       IF(KFIN.EQ.ITH(2)) IH=2
30187       IF(KFIN.EQ.ITH(3)) IH=3
30188       IF(KFIN.EQ.ITH(4)) IH=4
30189
30190       XMI=PMAS(KFIN,1)
30191       XMI2=XMI**2
30192       AXMI=ABS(XMI)
30193       AEM=PYALEM(XMI2)
30194       AS =PYALPS(XMI2)
30195       C1=AEM/XW
30196       XMI3=ABS(XMI**3)
30197
30198       TANB=RMSS(5)
30199       BETA=ATAN(TANB)
30200       CBETA=COS(BETA)
30201       SBETA=TANB*CBETA
30202       ALFA=RMSS(18)
30203       COSA=COS(ALFA)
30204       SINA=SIN(ALFA)
30205       ATRIT=RMSS(16)
30206       ATRIB=RMSS(15)
30207       ATRIL=RMSS(17)
30208       XMUZ=-RMSS(4)
30209
30210       IF(IH.EQ.4) GOTO 180
30211
30212 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
30213 C...H0_K -> CHI0_I + CHI0_J
30214       EH(1)=SINA
30215       EH(2)=COSA
30216       EH(3)=-SBETA
30217       DH(1)=COSA
30218       DH(2)=-SINA
30219       DH(3)=CBETA
30220       DO 110 IJ=1,4
30221         XMJ=SMZ(IJ)
30222         AXMJ=ABS(XMJ)
30223         DO 100 IK=1,IJ
30224           XMK=SMZ(IK)
30225           AXMK=ABS(XMK)
30226           IF(AXMI.GE.AXMJ+AXMK) THEN
30227             LKNT=LKNT+1
30228             F21K=0.5D0*
30229      &      EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2)
30230      &      -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+
30231      &      0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2)
30232      &      -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) )
30233             F12K=0.5D0*
30234      &      EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2)
30235      &      -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+
30236      &      0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2)
30237      &      -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) )
30238 C...SIGN OF MASSES I,J
30239             XML=XMK*ETAH(IH)
30240             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30241             IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
30242             IDLAM(LKNT,1)=KFNCHI(IJ)
30243             IDLAM(LKNT,2)=KFNCHI(IK)
30244             IDLAM(LKNT,3)=0
30245           ENDIF
30246   100   CONTINUE
30247   110 CONTINUE
30248
30249 C...H0_K -> CHI+_I CHI-_J
30250       DO 130 IJ=1,2
30251         XMJ=SMW(IJ)
30252         AXMJ=ABS(XMJ)
30253         DO 120 IK=1,2
30254           XMK=SMW(IK)
30255           AXMK=ABS(XMK)
30256           IF(AXMI.GE.AXMJ+AXMK) THEN
30257             LKNT=LKNT+1
30258             F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) -
30259      &      VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2
30260             F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) -
30261      &      VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2
30262             XML=-XMK*ETAH(IH)
30263             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K)
30264             IDLAM(LKNT,1)=KFCCHI(IJ)
30265             IDLAM(LKNT,2)=-KFCCHI(IK)
30266             IDLAM(LKNT,3)=0
30267           ENDIF
30268   120   CONTINUE
30269   130 CONTINUE
30270
30271 C...HIGGS TO SFERMION SFERMION
30272       DO 160 IFL=1,16
30273         IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160
30274         IJ=KSUSY1+IFL
30275         XMJL=PMAS(PYCOMP(IJ),1)
30276         XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
30277         IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
30278           XMJ=XMJL
30279           XMJ2=XMJ**2
30280           XL=PYLAMF(XMI2,XMJ2,XMJ2)
30281           XMF=PMAS(IFL,1)
30282           EI=KCHG(IFL,1)/3D0
30283           IDU=2-MOD(IFL,2)
30284
30285           IF(IH.EQ.1) THEN
30286             IF(IDU.EQ.1) THEN
30287               GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
30288      &        XMF**2/XMW*SINA/CBETA
30289               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
30290      &        XMF**2/XMW*SINA/CBETA
30291               IF(IFL.EQ.5) THEN
30292                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30293      &          ATRIB*SINA)
30294               ELSEIF(IFL.EQ.15) THEN
30295                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
30296      &          ATRIL*SINA)
30297               ELSE
30298                 GHLR=0D0
30299               ENDIF
30300             ELSE
30301               GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
30302      &        XMF**2/XMW*COSA/SBETA
30303               GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
30304      &        XMF**2/XMW*COSA/SBETA
30305               IF(IFL.EQ.6) THEN
30306                 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
30307      &          ATRIT*COSA)
30308               ELSE
30309                 GHLR=0D0
30310               ENDIF
30311             ENDIF
30312
30313           ELSEIF(IH.EQ.2) THEN
30314             IF(IDU.EQ.1) THEN
30315               GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
30316      &        XMF**2/XMW*COSA/CBETA
30317               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30318      &        XMF**2/XMW*COSA/CBETA
30319               IF(IFL.EQ.5) THEN
30320                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30321      &          ATRIB*COSA)
30322               ELSEIF(IFL.EQ.15) THEN
30323                 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
30324      &          ATRIL*COSA)
30325               ELSE
30326                 GHLR=0D0
30327               ENDIF
30328             ELSE
30329               GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
30330      &        XMF**2/XMW*SINA/SBETA
30331               GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
30332      &        XMF**2/XMW*SINA/SBETA
30333               IF(IFL.EQ.6) THEN
30334                 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
30335      &          ATRIT*SINA)
30336               ELSE
30337                 GHLR=0D0
30338               ENDIF
30339             ENDIF
30340
30341           ELSEIF(IH.EQ.3) THEN
30342             GHLL=0D0
30343             GHRR=0D0
30344             GHLR=0D0
30345             IF(IDU.EQ.1) THEN
30346               IF(IFL.EQ.5) THEN
30347                 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
30348               ELSEIF(IFL.EQ.15) THEN
30349                 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
30350               ENDIF
30351             ELSE
30352               IF(IFL.EQ.6) THEN
30353                 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
30354               ENDIF
30355             ENDIF
30356           ENDIF
30357           IF(IH.EQ.3) GOTO 140
30358
30359           AL=SFMIX(IFL,1)**2
30360           AR=SFMIX(IFL,2)**2
30361           ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
30362           IF(IFL.LE.6) THEN
30363             CF=3D0
30364           ELSE
30365             CF=1D0
30366           ENDIF
30367
30368           IF(AXMI.GE.2D0*XMJ) THEN
30369             LKNT=LKNT+1
30370             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30371      &      (GHLL*AL+GHRR*AR
30372      &      +2D0*GHLR*ALR)**2
30373             IDLAM(LKNT,1)=IJ
30374             IDLAM(LKNT,2)=-IJ
30375             IDLAM(LKNT,3)=0
30376           ENDIF
30377
30378           IF(AXMI.GE.2D0*XMJR) THEN
30379             LKNT=LKNT+1
30380             AL=SFMIX(IFL,3)**2
30381             AR=SFMIX(IFL,4)**2
30382             ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
30383             XMJ=XMJR
30384             XMJ2=XMJ**2
30385             XL=PYLAMF(XMI2,XMJ2,XMJ2)
30386             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30387      &      (GHLL*AL+GHRR*AR
30388      &      +2D0*GHLR*ALR)**2
30389             IDLAM(LKNT,1)=IJ+KSUSY1
30390             IDLAM(LKNT,2)=-(IJ+KSUSY1)
30391             IDLAM(LKNT,3)=0
30392           ENDIF
30393   140     CONTINUE
30394
30395           IF(AXMI.GE.XMJL+XMJR) THEN
30396             LKNT=LKNT+1
30397             AL=SFMIX(IFL,1)*SFMIX(IFL,3)
30398             AR=SFMIX(IFL,2)*SFMIX(IFL,4)
30399             ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
30400             XMJ=XMJR
30401             XMJ2=XMJ**2
30402             XL=PYLAMF(XMI2,XMJ2,XMJL**2)
30403             XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30404      &      (GHLL*AL+GHRR*AR)**2
30405             IDLAM(LKNT,1)=IJ
30406             IDLAM(LKNT,2)=-(IJ+KSUSY1)
30407             IDLAM(LKNT,3)=0
30408             LKNT=LKNT+1
30409             IDLAM(LKNT,1)=-IJ
30410             IDLAM(LKNT,2)=IJ+KSUSY1
30411             IDLAM(LKNT,3)=0
30412             XLAM(LKNT)=XLAM(LKNT-1)
30413           ENDIF
30414         ENDIF
30415   150   CONTINUE
30416   160 CONTINUE
30417   170 CONTINUE
30418
30419       GOTO 230
30420   180 CONTINUE
30421
30422 C...H+ -> CHI+_I + CHI0_J
30423       DO 200 IJ=1,4
30424         XMJ=SMZ(IJ)
30425         AXMJ=ABS(XMJ)
30426         XMJ2=XMJ**2
30427         DO 190 IK=1,2
30428           XMK=SMW(IK)
30429           AXMK=ABS(XMK)
30430           XMK2=XMK**2
30431           IF(AXMI.GE.AXMJ+AXMK) THEN
30432             LKNT=LKNT+1
30433             GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)*
30434      &      TANW)*VMIX(IK,2)/SR2)
30435             GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)*
30436      &      TANW)*UMIX(IK,2)/SR2)
30437             XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR)
30438             IDLAM(LKNT,1)=KFNCHI(IJ)
30439             IDLAM(LKNT,2)=KFCCHI(IK)
30440             IDLAM(LKNT,3)=0
30441           ENDIF
30442   190   CONTINUE
30443   200 CONTINUE
30444
30445       GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
30446       GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
30447       AL=0D0
30448       AR=0D0
30449       CF=3D0
30450
30451 C...H+ -> T_1 B_1~
30452       XM1=PMAS(PYCOMP(KSUSY1+6),1)
30453       XM2=PMAS(PYCOMP(KSUSY1+5),1)
30454       IF(XMI.GE.XM1+XM2) THEN
30455         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30456         LKNT=LKNT+1
30457         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30458      &  (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
30459         IDLAM(LKNT,1)=KSUSY1+6
30460         IDLAM(LKNT,2)=-(KSUSY1+5)
30461         IDLAM(LKNT,3)=0
30462       ENDIF
30463
30464 C...H+ -> T_2 B_1~
30465       XM1=PMAS(PYCOMP(KSUSY2+6),1)
30466       XM2=PMAS(PYCOMP(KSUSY1+5),1)
30467       IF(XMI.GE.XM1+XM2) THEN
30468         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30469         LKNT=LKNT+1
30470         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30471      &  (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
30472         IDLAM(LKNT,1)=KSUSY2+6
30473         IDLAM(LKNT,2)=-(KSUSY1+5)
30474         IDLAM(LKNT,3)=0
30475       ENDIF
30476
30477 C...H+ -> T_1 B_2~
30478       XM1=PMAS(PYCOMP(KSUSY1+6),1)
30479       XM2=PMAS(PYCOMP(KSUSY2+5),1)
30480       IF(XMI.GE.XM1+XM2) THEN
30481         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30482         LKNT=LKNT+1
30483         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30484      &  (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
30485         IDLAM(LKNT,1)=KSUSY1+6
30486         IDLAM(LKNT,2)=-(KSUSY2+5)
30487         IDLAM(LKNT,3)=0
30488       ENDIF
30489
30490 C...H+ -> T_2 B_2~
30491       XM1=PMAS(PYCOMP(KSUSY2+6),1)
30492       XM2=PMAS(PYCOMP(KSUSY2+5),1)
30493       IF(XMI.GE.XM1+XM2) THEN
30494         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30495         LKNT=LKNT+1
30496         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
30497      &  (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
30498         IDLAM(LKNT,1)=KSUSY2+6
30499         IDLAM(LKNT,2)=-(KSUSY2+5)
30500         IDLAM(LKNT,3)=0
30501       ENDIF
30502
30503 C...H+ -> UL DL~
30504       GL=-XMW/SR2*SIN(2D0*BETA)
30505       DO 210 IJ=1,3,2
30506         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30507         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30508         IF(XMI.GE.XM1+XM2) THEN
30509           XL=PYLAMF(XMI2,XM1**2,XM2**2)
30510           LKNT=LKNT+1
30511           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30512           IDLAM(LKNT,1)=-(KSUSY1+IJ)
30513           IDLAM(LKNT,2)=KSUSY1+IJ+1
30514           IDLAM(LKNT,3)=0
30515         ENDIF
30516   210 CONTINUE
30517
30518 C...H+ -> EL~ NUL
30519       CF=1D0
30520       DO 220 IJ=11,13,2
30521         XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
30522         XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
30523         IF(XMI.GE.XM1+XM2) THEN
30524           XL=PYLAMF(XMI2,XM1**2,XM2**2)
30525           LKNT=LKNT+1
30526           XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2
30527           IDLAM(LKNT,1)=-(KSUSY1+IJ)
30528           IDLAM(LKNT,2)=KSUSY1+IJ+1
30529           IDLAM(LKNT,3)=0
30530         ENDIF
30531   220 CONTINUE
30532
30533 C...H+ -> TAU1 NUTAUL
30534       XM1=PMAS(PYCOMP(KSUSY1+15),1)
30535       XM2=PMAS(PYCOMP(KSUSY1+16),1)
30536       IF(XMI.GE.XM1+XM2) THEN
30537         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30538         LKNT=LKNT+1
30539         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2
30540         IDLAM(LKNT,1)=-(KSUSY1+15)
30541         IDLAM(LKNT,2)= KSUSY1+16
30542         IDLAM(LKNT,3)=0
30543       ENDIF
30544
30545 C...H+ -> TAU2 NUTAUL
30546       XM1=PMAS(PYCOMP(KSUSY2+15),1)
30547       XM2=PMAS(PYCOMP(KSUSY1+16),1)
30548       IF(XMI.GE.XM1+XM2) THEN
30549         XL=PYLAMF(XMI2,XM1**2,XM2**2)
30550         LKNT=LKNT+1
30551         XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2
30552         IDLAM(LKNT,1)=-(KSUSY2+15)
30553         IDLAM(LKNT,2)= KSUSY1+16
30554         IDLAM(LKNT,3)=0
30555       ENDIF
30556
30557   230 CONTINUE
30558       IKNT=LKNT
30559       XLAM(0)=0D0
30560       DO 240 I=1,IKNT
30561         IF(XLAM(I).LE.0D0) XLAM(I)=0D0
30562         XLAM(0)=XLAM(0)+XLAM(I)
30563   240 CONTINUE
30564       IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
30565
30566       RETURN
30567       END
30568
30569 C*********************************************************************
30570
30571 *$ CREATE PYH2XX.FOR
30572 *COPY PYH2XX
30573 C...PYH2XX
30574 C...Calculates the decay rate for a Higgs to an ino pair.
30575
30576       FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR)
30577
30578 C...Double precision and integer declarations.
30579       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30580       INTEGER PYK,PYCHGE,PYCOMP
30581 C...Commonblocks.
30582       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30583       SAVE /PYDAT1/
30584
30585 C...Local variables.
30586       DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
30587       DOUBLE PRECISION XL,PYLAMF,C1
30588       DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
30589
30590       XMI2=XM1**2
30591       XMI3=ABS(XM1**3)
30592       XMJ2=XM2**2
30593       XMK2=XM3**2
30594       XL=PYLAMF(XMI2,XMJ2,XMK2)
30595       PYH2XX=C1/4D0/XMI3*SQRT(XL)
30596      &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)-
30597      &4D0*GL*GR*XM3*XM2)
30598       IF(PYH2XX.LT.0D0) THEN
30599         WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
30600         WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3
30601         STOP
30602       ENDIF
30603
30604       RETURN
30605       END
30606
30607 C*********************************************************************
30608
30609 *$ CREATE PYGAUS.FOR
30610 *COPY PYGAUS
30611 C...PYGAUS
30612 C...Integration by adaptive Gaussian quadrature.
30613 C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
30614
30615       FUNCTION PYGAUS(F, A, B, EPS)
30616
30617 C...Double precision and integer declarations.
30618       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30619       INTEGER PYK,PYCHGE,PYCOMP
30620
30621 C...Local declarations.
30622       EXTERNAL F
30623       DOUBLE PRECISION W(12), X(12)
30624       DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
30625       DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
30626       DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
30627       DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
30628       DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
30629       DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
30630       DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
30631       DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
30632       DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
30633       DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
30634       DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
30635       DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
30636
30637 C...The Gaussian quadrature algorithm.
30638       H = 0D0
30639       IF(B .EQ. A) GO TO 140
30640       CONST = 5D-3 / ABS(B-A)
30641       BB = A
30642   100 CONTINUE
30643       AA = BB
30644       BB = B
30645   110 CONTINUE
30646       C1 = 0.5D0*(BB+AA)
30647       C2 = 0.5D0*(BB-AA)
30648       S8 = 0D0
30649       DO 120 I = 1, 4
30650         U = C2*X(I)
30651         S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
30652   120 CONTINUE
30653       S16 = 0D0
30654       DO 130 I = 5, 12
30655         U = C2*X(I)
30656         S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
30657   130 CONTINUE
30658       S16 = C2*S16
30659       IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
30660         H = H + S16
30661         IF(BB .NE. B) GO TO 100
30662       ELSE
30663         BB = C1
30664         IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110
30665         H = 0D0
30666         CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
30667         GO TO 140
30668       ENDIF
30669   140 CONTINUE
30670       PYGAUS = H
30671
30672       RETURN
30673       END
30674
30675 C*********************************************************************
30676
30677 *$ CREATE PYSIMP.FOR
30678 *COPY PYSIMP
30679 C...PYSIMP
30680 C...Simpson formula for an integral.
30681
30682       FUNCTION PYSIMP(Y,X0,X1,N)
30683
30684 C...Double precision and integer declarations.
30685       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30686       INTEGER PYK,PYCHGE,PYCOMP
30687
30688 C...Local variables.
30689       DOUBLE PRECISION Y,X0,X1,H,S
30690       DIMENSION Y(0:N)
30691
30692       S=0D0
30693       H=(X1-X0)/N
30694       DO 100 I=0,N-2,2
30695         S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
30696   100 CONTINUE
30697       PYSIMP=S*H/3D0
30698
30699       RETURN
30700       END
30701
30702 C*********************************************************************
30703
30704 *$ CREATE PYLAMF.FOR
30705 *COPY PYLAMF
30706 C...PYLAMF
30707 C...The standard lambda function.
30708
30709       FUNCTION PYLAMF(X,Y,Z)
30710
30711 C...Double precision and integer declarations.
30712       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30713       INTEGER PYK,PYCHGE,PYCOMP
30714
30715 C...Local variables.
30716       DOUBLE PRECISION PYLAMF,X,Y,Z
30717
30718       PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
30719       IF(PYLAMF.LT.0D0) PYLAMF=0D0
30720
30721       RETURN
30722       END
30723
30724 C*********************************************************************
30725
30726 *$ CREATE PYTBDY.FOR
30727 *COPY PYTBDY
30728 C...PYTBDY
30729 C...Generates 3-body decays of gauginos.
30730
30731       SUBROUTINE PYTBDY(XM)
30732
30733 C...Double precision and integer declarations.
30734       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30735       INTEGER PYK,PYCHGE,PYCOMP
30736 C...Parameter statement to help give large particle numbers.
30737       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
30738 C...Commonblocks.
30739       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30740       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30741       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30742       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
30743       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30744       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/
30745
30746 C...Local variables.
30747       DOUBLE PRECISION XM(5)
30748       DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
30749       DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
30750       DOUBLE PRECISION CPHI1,SPHI1
30751       DOUBLE PRECISION S23DEL,EPS
30752       DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
30753       PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
30754       DOUBLE PRECISION F1,F2,X0,X1,X2,X3
30755       DATA EPS/1D-6/
30756
30757 C...GENERATE S12
30758       S12MIN=(XM(1)+XM(2))**2
30759       S12MAX=(XM(5)-XM(3))**2
30760       YJACO1=S12MAX-S12MIN
30761
30762 C...FIND S12*
30763       AX=S12MIN
30764       CX=S12MAX
30765       BX=S12MIN+0.5D0*YJACO1
30766       X0=AX
30767       X3=CX
30768       IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
30769         X1=BX
30770         X2=BX+C*(CX-BX)
30771       ELSE
30772         X2=BX
30773         X1=BX-C*(BX-AX)
30774       ENDIF
30775
30776 C...SOLVE FOR F1 AND F2
30777       S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30778      &-(2D0*XM(1)*XM(2))**2
30779       S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30780      &-(2D0*XM(3)*XM(5))**2
30781       S23DF1=S23DF1*EPS
30782       S23DF2=S23DF2*EPS
30783       S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30784       F1=-2D0*S23DEL/EPS
30785       S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30786      &-(2D0*XM(1)*XM(2))**2
30787       S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30788      &-(2D0*XM(3)*XM(5))**2
30789       S23DF1=S23DF1*EPS
30790       S23DF2=S23DF2*EPS
30791       S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30792       F2=-2D0*S23DEL/EPS
30793
30794   100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
30795         IF(F2.LT.F1)THEN
30796           X0=X1
30797           X1=X2
30798           X2=R*X1+C*X3
30799           F1=F2
30800           S23DF1=(X2-XM(2)**2-XM(1)**2)**2
30801      &    -(2D0*XM(1)*XM(2))**2
30802           S23DF2=(X2-XM(3)**2-XM(5)**2)**2
30803      &    -(2D0*XM(3)*XM(5))**2
30804           S23DF1=S23DF1*EPS
30805           S23DF2=S23DF2*EPS
30806           S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2)
30807           F2=-2D0*S23DEL/EPS
30808         ELSE
30809           X3=X2
30810           X2=X1
30811           X1=R*X2+C*X0
30812           F2=F1
30813           S23DF1=(X1-XM(2)**2-XM(1)**2)**2
30814      &    -(2D0*XM(1)*XM(2))**2
30815           S23DF2=(X1-XM(3)**2-XM(5)**2)**2
30816      &    -(2D0*XM(3)*XM(5))**2
30817           S23DF1=S23DF1*EPS
30818           S23DF2=S23DF2*EPS
30819           S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1)
30820           F1=-2D0*S23DEL/EPS
30821         ENDIF
30822         GOTO 100
30823       ENDIF
30824 C...WE WANT THE MAXIMUM, NOT THE MINIMUM
30825       IF(F1.LT.F2)THEN
30826         GOLDEN=-F1
30827         XMIN=X1
30828       ELSE
30829         GOLDEN=-F2
30830         XMIN=X2
30831       ENDIF
30832
30833       IKNT=0
30834   110 S12=S12MIN+PYR(0)*YJACO1
30835       IKNT=IKNT+1
30836 C...GENERATE S23
30837       S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
30838      &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
30839       S23DF1=(S12-XM(2)**2-XM(1)**2)**2
30840      &-(2D0*XM(1)*XM(2))**2
30841       S23DF2=(S12-XM(3)**2-XM(5)**2)**2
30842      &-(2D0*XM(3)*XM(5))**2
30843       S23DF1=S23DF1*EPS
30844       S23DF2=S23DF2*EPS
30845       S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12)
30846       S23DEL=S23DEL/EPS
30847       S23MIN=S23AVE-S23DEL
30848       S23MAX=S23AVE+S23DEL
30849       YJACO2=S23MAX-S23MIN
30850       S23=S23MIN+PYR(0)*YJACO2
30851
30852 C...CHECK THE SAMPLING
30853       IF(IKNT.GT.100) THEN
30854         WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
30855         GOTO 120
30856       ENDIF
30857       IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110
30858   120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
30859       D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
30860       D2=XM(5)-D1-D3
30861       P1=SQRT(D1*D1-XM(1)**2)
30862       P2=SQRT(D2*D2-XM(2)**2)
30863       P3=SQRT(D3*D3-XM(3)**2)
30864       CTHE1=2D0*PYR(0)-1D0
30865       ANG1=2D0*PYR(0)*PARU(1)
30866       CPHI1=COS(ANG1)
30867       SPHI1=SIN(ANG1)
30868       ARG=1D0-CTHE1**2
30869       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30870       STHE1=SQRT(ARG)
30871       P(N+1,1)=P1*STHE1*CPHI1
30872       P(N+1,2)=P1*STHE1*SPHI1
30873       P(N+1,3)=P1*CTHE1
30874       P(N+1,4)=D1
30875
30876 C...GET CPHI3
30877       ANG3=2D0*PYR(0)*PARU(1)
30878       CPHI3=COS(ANG3)
30879       SPHI3=SIN(ANG3)
30880       CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
30881       ARG=1D0-CTHE3**2
30882       IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
30883       STHE3=SQRT(ARG)
30884       P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
30885      &+P3*STHE3*SPHI3*SPHI1
30886      &+P3*CTHE3*STHE1*CPHI1
30887       P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
30888      &-P3*STHE3*SPHI3*CPHI1
30889      &+P3*CTHE3*STHE1*SPHI1
30890       P(N+3,3)=P3*STHE3*CPHI3*STHE1
30891      &+P3*CTHE3*CTHE1
30892       P(N+3,4)=D3
30893
30894       DO 130 I=1,3
30895         P(N+2,I)=-P(N+1,I)-P(N+3,I)
30896   130 CONTINUE
30897       P(N+2,4)=D2
30898
30899       RETURN
30900       END
30901
30902 C*********************************************************************
30903
30904 *$ CREATE PY1ENT.FOR
30905 *COPY PY1ENT
30906 C...PY1ENT
30907 C...Stores one parton/particle in commonblock PYJETS.
30908
30909       SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
30910
30911 C...Double precision and integer declarations.
30912       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30913       INTEGER PYK,PYCHGE,PYCOMP
30914 C...Commonblocks.
30915       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30916       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30917       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30918       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30919
30920 C...Standard checks.
30921       MSTU(28)=0
30922       IF(MSTU(12).GE.1) CALL PYLIST(0)
30923       IPA=MAX(1,IABS(IP))
30924       IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
30925      &'(PY1ENT:) writing outside PYJETS memory')
30926       KC=PYCOMP(KF)
30927       IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
30928
30929 C...Find mass. Reset K, P and V vectors.
30930       PM=0D0
30931       IF(MSTU(10).EQ.1) PM=P(IPA,5)
30932       IF(MSTU(10).GE.2) PM=PYMASS(KF)
30933       DO 100 J=1,5
30934         K(IPA,J)=0
30935         P(IPA,J)=0D0
30936         V(IPA,J)=0D0
30937   100 CONTINUE
30938
30939 C...Store parton/particle in K and P vectors.
30940       K(IPA,1)=1
30941       IF(IP.LT.0) K(IPA,1)=2
30942       K(IPA,2)=KF
30943       P(IPA,5)=PM
30944       P(IPA,4)=MAX(PE,PM)
30945       PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
30946       P(IPA,1)=PA*SIN(THE)*COS(PHI)
30947       P(IPA,2)=PA*SIN(THE)*SIN(PHI)
30948       P(IPA,3)=PA*COS(THE)
30949
30950 C...Set N. Optionally fragment/decay.
30951       N=IPA
30952       IF(IP.EQ.0) CALL PYEXEC
30953
30954       RETURN
30955       END
30956
30957 C*********************************************************************
30958
30959 *$ CREATE PY2ENT.FOR
30960 *COPY PY2ENT
30961 C...PY2ENT
30962 C...Stores two partons/particles in their CM frame,
30963 C...with the first along the +z axis.
30964
30965       SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
30966
30967 C...Double precision and integer declarations.
30968       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30969       INTEGER PYK,PYCHGE,PYCOMP
30970 C...Commonblocks.
30971       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
30972       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30973       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30974       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
30975
30976 C...Standard checks.
30977       MSTU(28)=0
30978       IF(MSTU(12).GE.1) CALL PYLIST(0)
30979       IPA=MAX(1,IABS(IP))
30980       IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
30981      &'(PY2ENT:) writing outside PYJETS memory')
30982       KC1=PYCOMP(KF1)
30983       KC2=PYCOMP(KF2)
30984       IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
30985      &'(PY2ENT:) unknown flavour code')
30986
30987 C...Find masses. Reset K, P and V vectors.
30988       PM1=0D0
30989       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
30990       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
30991       PM2=0D0
30992       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
30993       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
30994       DO 110 I=IPA,IPA+1
30995         DO 100 J=1,5
30996           K(I,J)=0
30997           P(I,J)=0D0
30998           V(I,J)=0D0
30999   100   CONTINUE
31000   110 CONTINUE
31001
31002 C...Check flavours.
31003       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31004       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31005       IF(MSTU(19).EQ.1) THEN
31006         MSTU(19)=0
31007       ELSE
31008         IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
31009      &  '(PY2ENT:) unphysical flavour combination')
31010       ENDIF
31011       K(IPA,2)=KF1
31012       K(IPA+1,2)=KF2
31013
31014 C...Store partons/particles in K vectors for normal case.
31015       IF(IP.GE.0) THEN
31016         K(IPA,1)=1
31017         IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
31018         K(IPA+1,1)=1
31019
31020 C...Store partons in K vectors for parton shower evolution.
31021       ELSE
31022         K(IPA,1)=3
31023         K(IPA+1,1)=3
31024         K(IPA,4)=MSTU(5)*(IPA+1)
31025         K(IPA,5)=K(IPA,4)
31026         K(IPA+1,4)=MSTU(5)*IPA
31027         K(IPA+1,5)=K(IPA+1,4)
31028       ENDIF
31029
31030 C...Check kinematics and store partons/particles in P vectors.
31031       IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
31032      &'(PY2ENT:) energy smaller than sum of masses')
31033       PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
31034      &(2D0*PECM)
31035       P(IPA,3)=PA
31036       P(IPA,4)=SQRT(PM1**2+PA**2)
31037       P(IPA,5)=PM1
31038       P(IPA+1,3)=-PA
31039       P(IPA+1,4)=SQRT(PM2**2+PA**2)
31040       P(IPA+1,5)=PM2
31041
31042 C...Set N. Optionally fragment/decay.
31043       N=IPA+1
31044       IF(IP.EQ.0) CALL PYEXEC
31045
31046       RETURN
31047       END
31048
31049 C*********************************************************************
31050
31051 *$ CREATE PY3ENT.FOR
31052 *COPY PY3ENT
31053 C...PY3ENT
31054 C...Stores three partons or particles in their CM frame,
31055 C...with the first along the +z axis and the third in the (x,z)
31056 C...plane with x > 0.
31057
31058       SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
31059
31060 C...Double precision and integer declarations.
31061       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31062       INTEGER PYK,PYCHGE,PYCOMP
31063 C...Commonblocks.
31064       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31065       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31066       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31067       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31068
31069 C...Standard checks.
31070       MSTU(28)=0
31071       IF(MSTU(12).GE.1) CALL PYLIST(0)
31072       IPA=MAX(1,IABS(IP))
31073       IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
31074      &'(PY3ENT:) writing outside PYJETS memory')
31075       KC1=PYCOMP(KF1)
31076       KC2=PYCOMP(KF2)
31077       KC3=PYCOMP(KF3)
31078       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
31079      &'(PY3ENT:) unknown flavour code')
31080
31081 C...Find masses. Reset K, P and V vectors.
31082       PM1=0D0
31083       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31084       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31085       PM2=0D0
31086       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31087       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31088       PM3=0D0
31089       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31090       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31091       DO 110 I=IPA,IPA+2
31092         DO 100 J=1,5
31093           K(I,J)=0
31094           P(I,J)=0D0
31095           V(I,J)=0D0
31096   100   CONTINUE
31097   110 CONTINUE
31098
31099 C...Check flavours.
31100       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31101       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31102       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31103       IF(MSTU(19).EQ.1) THEN
31104         MSTU(19)=0
31105       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
31106       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
31107      &  KQ1+KQ3.EQ.4)) THEN
31108       ELSE
31109         CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
31110       ENDIF
31111       K(IPA,2)=KF1
31112       K(IPA+1,2)=KF2
31113       K(IPA+2,2)=KF3
31114
31115 C...Store partons/particles in K vectors for normal case.
31116       IF(IP.GE.0) THEN
31117         K(IPA,1)=1
31118         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
31119         K(IPA+1,1)=1
31120         IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
31121         K(IPA+2,1)=1
31122
31123 C...Store partons in K vectors for parton shower evolution.
31124       ELSE
31125         K(IPA,1)=3
31126         K(IPA+1,1)=3
31127         K(IPA+2,1)=3
31128         KCS=4
31129         IF(KQ1.EQ.-1) KCS=5
31130         K(IPA,KCS)=MSTU(5)*(IPA+1)
31131         K(IPA,9-KCS)=MSTU(5)*(IPA+2)
31132         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31133         K(IPA+1,9-KCS)=MSTU(5)*IPA
31134         K(IPA+2,KCS)=MSTU(5)*IPA
31135         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31136       ENDIF
31137
31138 C...Check kinematics.
31139       MKERR=0
31140       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
31141      &0.5D0*X3*PECM.LE.PM3) MKERR=1
31142       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31143       PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
31144       PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
31145       CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
31146       CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
31147       IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
31148       CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
31149       IF(MKERR.NE.0) CALL PYERRM(13,
31150      &'(PY3ENT:) unphysical kinematical variable setup')
31151
31152 C...Store partons/particles in P vectors.
31153       P(IPA,3)=PA1
31154       P(IPA,4)=SQRT(PA1**2+PM1**2)
31155       P(IPA,5)=PM1
31156       P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
31157       P(IPA+2,3)=PA3*CTHE3
31158       P(IPA+2,4)=SQRT(PA3**2+PM3**2)
31159       P(IPA+2,5)=PM3
31160       P(IPA+1,1)=-P(IPA+2,1)
31161       P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
31162       P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
31163       P(IPA+1,5)=PM2
31164
31165 C...Set N. Optionally fragment/decay.
31166       N=IPA+2
31167       IF(IP.EQ.0) CALL PYEXEC
31168
31169       RETURN
31170       END
31171
31172 C*********************************************************************
31173
31174 *$ CREATE PY4ENT.FOR
31175 *COPY PY4ENT
31176 C...PY4ENT
31177 C...Stores four partons or particles in their CM frame, with
31178 C...the first along the +z axis, the last in the xz plane with x > 0
31179 C...and the second having y < 0 and y > 0 with equal probability.
31180
31181       SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
31182
31183 C...Double precision and integer declarations.
31184       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31185       INTEGER PYK,PYCHGE,PYCOMP
31186 C...Commonblocks.
31187       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31188       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31189       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31190       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31191
31192 C...Standard checks.
31193       MSTU(28)=0
31194       IF(MSTU(12).GE.1) CALL PYLIST(0)
31195       IPA=MAX(1,IABS(IP))
31196       IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
31197      &'(PY4ENT:) writing outside PYJETS momory')
31198       KC1=PYCOMP(KF1)
31199       KC2=PYCOMP(KF2)
31200       KC3=PYCOMP(KF3)
31201       KC4=PYCOMP(KF4)
31202       IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
31203      &'(PY4ENT:) unknown flavour code')
31204
31205 C...Find masses. Reset K, P and V vectors.
31206       PM1=0D0
31207       IF(MSTU(10).EQ.1) PM1=P(IPA,5)
31208       IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
31209       PM2=0D0
31210       IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
31211       IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
31212       PM3=0D0
31213       IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
31214       IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
31215       PM4=0D0
31216       IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
31217       IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
31218       DO 110 I=IPA,IPA+3
31219         DO 100 J=1,5
31220           K(I,J)=0
31221           P(I,J)=0D0
31222           V(I,J)=0D0
31223   100   CONTINUE
31224   110 CONTINUE
31225
31226 C...Check flavours.
31227       KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
31228       KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
31229       KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
31230       KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
31231       IF(MSTU(19).EQ.1) THEN
31232         MSTU(19)=0
31233       ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
31234       ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
31235      &  KQ1+KQ4.EQ.4)) THEN
31236       ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
31237      &  THEN
31238       ELSE
31239         CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
31240       ENDIF
31241       K(IPA,2)=KF1
31242       K(IPA+1,2)=KF2
31243       K(IPA+2,2)=KF3
31244       K(IPA+3,2)=KF4
31245
31246 C...Store partons/particles in K vectors for normal case.
31247       IF(IP.GE.0) THEN
31248         K(IPA,1)=1
31249         IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
31250         K(IPA+1,1)=1
31251         IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
31252      &  K(IPA+1,1)=2
31253         K(IPA+2,1)=1
31254         IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
31255         K(IPA+3,1)=1
31256
31257 C...Store partons for parton shower evolution from q-g-g-qbar or
31258 C...g-g-g-g event.
31259       ELSEIF(KQ1+KQ2.NE.0) THEN
31260         K(IPA,1)=3
31261         K(IPA+1,1)=3
31262         K(IPA+2,1)=3
31263         K(IPA+3,1)=3
31264         KCS=4
31265         IF(KQ1.EQ.-1) KCS=5
31266         K(IPA,KCS)=MSTU(5)*(IPA+1)
31267         K(IPA,9-KCS)=MSTU(5)*(IPA+3)
31268         K(IPA+1,KCS)=MSTU(5)*(IPA+2)
31269         K(IPA+1,9-KCS)=MSTU(5)*IPA
31270         K(IPA+2,KCS)=MSTU(5)*(IPA+3)
31271         K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
31272         K(IPA+3,KCS)=MSTU(5)*IPA
31273         K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
31274
31275 C...Store partons for parton shower evolution from q-qbar-q-qbar event.
31276       ELSE
31277         K(IPA,1)=3
31278         K(IPA+1,1)=3
31279         K(IPA+2,1)=3
31280         K(IPA+3,1)=3
31281         K(IPA,4)=MSTU(5)*(IPA+1)
31282         K(IPA,5)=K(IPA,4)
31283         K(IPA+1,4)=MSTU(5)*IPA
31284         K(IPA+1,5)=K(IPA+1,4)
31285         K(IPA+2,4)=MSTU(5)*(IPA+3)
31286         K(IPA+2,5)=K(IPA+2,4)
31287         K(IPA+3,4)=MSTU(5)*(IPA+2)
31288         K(IPA+3,5)=K(IPA+3,4)
31289       ENDIF
31290
31291 C...Check kinematics.
31292       MKERR=0
31293       IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
31294      &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
31295      &MKERR=1
31296       PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
31297       PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
31298       PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
31299       X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
31300       CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
31301       IF(ABS(CTHE4).GE.1.002D0) MKERR=1
31302       CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
31303       STHE4=SQRT(1D0-CTHE4**2)
31304       CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
31305       IF(ABS(CTHE2).GE.1.002D0) MKERR=1
31306       CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
31307       STHE2=SQRT(1D0-CTHE2**2)
31308       CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
31309      &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
31310       IF(ABS(CPHI2).GE.1.05D0) MKERR=1
31311       CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
31312       IF(MKERR.EQ.1) CALL PYERRM(13,
31313      &'(PY4ENT:) unphysical kinematical variable setup')
31314
31315 C...Store partons/particles in P vectors.
31316       P(IPA,3)=PA1
31317       P(IPA,4)=SQRT(PA1**2+PM1**2)
31318       P(IPA,5)=PM1
31319       P(IPA+3,1)=PA4*STHE4
31320       P(IPA+3,3)=PA4*CTHE4
31321       P(IPA+3,4)=SQRT(PA4**2+PM4**2)
31322       P(IPA+3,5)=PM4
31323       P(IPA+1,1)=PA2*STHE2*CPHI2
31324       P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
31325       P(IPA+1,3)=PA2*CTHE2
31326       P(IPA+1,4)=SQRT(PA2**2+PM2**2)
31327       P(IPA+1,5)=PM2
31328       P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
31329       P(IPA+2,2)=-P(IPA+1,2)
31330       P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
31331       P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
31332       P(IPA+2,5)=PM3
31333
31334 C...Set N. Optionally fragment/decay.
31335       N=IPA+3
31336       IF(IP.EQ.0) CALL PYEXEC
31337
31338       RETURN
31339       END
31340
31341 C*********************************************************************
31342
31343 *$ CREATE PYJOIN.FOR
31344 *COPY PYJOIN
31345 C...PYJOIN
31346 C...Connects a sequence of partons with colour flow indices,
31347 C...as required for subsequent shower evolution (or other operations).
31348
31349       SUBROUTINE PYJOIN(NJOIN,IJOIN)
31350
31351 C...Double precision and integer declarations.
31352       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31353       INTEGER PYK,PYCHGE,PYCOMP
31354 C...Commonblocks.
31355       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31356       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31357       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31358       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
31359 C...Local array.
31360       DIMENSION IJOIN(*)
31361
31362 C...Check that partons are of right types to be connected.
31363       IF(NJOIN.LT.2) GOTO 120
31364       KQSUM=0
31365       DO 100 IJN=1,NJOIN
31366         I=IJOIN(IJN)
31367         IF(I.LE.0.OR.I.GT.N) GOTO 120
31368         IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
31369         KC=PYCOMP(K(I,2))
31370         IF(KC.EQ.0) GOTO 120
31371         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
31372         IF(KQ.EQ.0) GOTO 120
31373         IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
31374         IF(KQ.NE.2) KQSUM=KQSUM+KQ
31375         IF(IJN.EQ.1) KQS=KQ
31376   100 CONTINUE
31377       IF(KQSUM.NE.0) GOTO 120
31378
31379 C...Connect the partons sequentially (closing for gluon loop).
31380       KCS=(9-KQS)/2
31381       IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
31382       DO 110 IJN=1,NJOIN
31383         I=IJOIN(IJN)
31384         K(I,1)=3
31385         IF(IJN.NE.1) IP=IJOIN(IJN-1)
31386         IF(IJN.EQ.1) IP=IJOIN(NJOIN)
31387         IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
31388         IF(IJN.EQ.NJOIN) IN=IJOIN(1)
31389         K(I,KCS)=MSTU(5)*IN
31390         K(I,9-KCS)=MSTU(5)*IP
31391         IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
31392         IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
31393   110 CONTINUE
31394
31395 C...Error exit: no action taken.
31396       RETURN
31397   120 CALL PYERRM(12,
31398      &'(PYJOIN:) given entries can not be joined by one string')
31399
31400       RETURN
31401       END
31402
31403 C*********************************************************************
31404
31405 *$ CREATE PYGIVE.FOR
31406 *COPY PYGIVE
31407 C...PYGIVE
31408 C...Sets values of commonblock variables.
31409
31410       SUBROUTINE PYGIVE(CHIN)
31411
31412 C...Double precision and integer declarations.
31413       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31414       INTEGER PYK,PYCHGE,PYCOMP
31415 C...Commonblocks.
31416       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31417       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31418       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31419       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31420       COMMON/PYDAT4/CHAF(500,2)
31421       CHARACTER CHAF*16
31422       COMMON/PYDATR/MRPY(6),RRPY(100)
31423       COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31424       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31425       COMMON/PYINT1/MINT(400),VINT(400)
31426       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31427       COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31428       COMMON/PYINT4/MWID(500),WIDS(500,5)
31429       COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
31430       COMMON/PYINT6/PROC(0:500)
31431       CHARACTER PROC*28
31432       COMMON/PYINT7/SIGT(0:6,0:6,0:5)
31433       COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
31434      &XPDIR(-6:6)
31435       COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31436       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
31437      &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
31438      &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/
31439 C...Local arrays and character variables.
31440       CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
31441      &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10,
31442      &CHINR*16
31443       DIMENSION MSVAR(49,8)
31444
31445 C...For each variable to be translated give: name,
31446 C...integer/real/character, no. of indices, lower&upper index bounds.
31447       DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
31448      &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
31449      &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
31450      &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
31451      &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
31452      &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/
31453       DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0,  1,2,1,4000,1,5,2*0,
31454      &2,2,1,4000,1,5,2*0,  2,2,1,4000,1,5,2*0,  1,1,1,200,4*0,
31455      &2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
31456      &1,2,1,500,1,4,2*0,  2,2,1,500,1,4,2*0,  2,1,1,2000,4*0,
31457      &2,2,1,4,1,4,2*0,  1,2,1,500,1,3,2*0,  1,2,1,4000,1,2,2*0,
31458      &2,1,1,4000,4*0,  1,2,1,4000,1,5,2*0,  3,2,1,500,1,2,2*0,
31459      &1,1,1,6,4*0,  2,1,1,100,4*0,
31460      &1,7*0,  1,1,1,500,4*0,  1,2,1,2,-40,40,2*0,  2,1,1,200,4*0,
31461      &1,1,1,200,4*0,  2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,
31462      &1,1,1,400,4*0,  2,1,1,400,4*0,  1,1,1,500,4*0,
31463      &1,2,1,500,1,2,2*0,  2,2,1,500,1,20,2*0,  1,3,1,40,1,4,1,2,
31464      &2,2,1,2,-40,40,2*0,  1,2,1,1000,1,3,2*0,  2,1,1,1000,4*0,
31465      &1,1,1,500,4*0,   2,2,1,500,1,5,2*0,   1,2,0,500,1,3,2*0,
31466      &2,2,0,500,1,3,2*0,   4,1,0,500,4*0,   2,3,0,6,0,6,0,5,
31467      &2,1,-6,6,4*0,     2,1,-6,6,4*0,    2,1,-6,6,4*0,
31468      &2,1,-6,6,4*0,  2,1,-6,6,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0/
31469       DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
31470      &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
31471
31472 C...Length of character variable. Subdivide it into instructions.
31473       IF(MSTU(12).GE.1) CALL PYLIST(0)
31474       CHBIT=CHIN//' '
31475       LBIT=101
31476   100 LBIT=LBIT-1
31477       IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
31478       LTOT=0
31479       DO 110 LCOM=1,LBIT
31480         IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
31481         LTOT=LTOT+1
31482         CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
31483   110 CONTINUE
31484       LLOW=0
31485   120 LHIG=LLOW+1
31486   130 LHIG=LHIG+1
31487       IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
31488       LBIT=LHIG-LLOW-1
31489       CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
31490
31491 C...Identify commonblock variable.
31492       LNAM=1
31493   140 LNAM=LNAM+1
31494       IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
31495      &LNAM.LE.6) GOTO 140
31496       CHNAM=CHBIT(1:LNAM-1)//' '
31497       DO 160 LCOM=1,LNAM-1
31498         DO 150 LALP=1,26
31499           IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
31500      &    CHALP(2)(LALP:LALP)
31501   150   CONTINUE
31502   160 CONTINUE
31503       IVAR=0
31504       DO 170 IV=1,49
31505         IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
31506   170 CONTINUE
31507       IF(IVAR.EQ.0) THEN
31508         CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
31509         LLOW=LHIG
31510         IF(LLOW.LT.LTOT) GOTO 120
31511         RETURN
31512       ENDIF
31513
31514 C...Identify any indices.
31515       I1=0
31516       I2=0
31517       I3=0
31518       NINDX=0
31519       IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
31520         LIND=LNAM
31521   180   LIND=LIND+1
31522         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180
31523         CHIND=' '
31524         IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
31525      &  .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17))
31526      &  THEN
31527           CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
31528           READ(CHIND,'(I8)') KF
31529           I1=PYCOMP(KF)
31530         ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
31531      &    'c') THEN
31532           CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
31533      &    CHNAM)
31534           LLOW=LHIG
31535           IF(LLOW.LT.LTOT) GOTO 120
31536           RETURN
31537         ELSE
31538           CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31539           READ(CHIND,'(I8)') I1
31540         ENDIF
31541         LNAM=LIND
31542         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31543         NINDX=1
31544       ENDIF
31545       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31546         LIND=LNAM
31547   190   LIND=LIND+1
31548         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
31549         CHIND=' '
31550         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31551         READ(CHIND,'(I8)') I2
31552         LNAM=LIND
31553         IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
31554         NINDX=2
31555       ENDIF
31556       IF(CHBIT(LNAM:LNAM).EQ.',') THEN
31557         LIND=LNAM
31558   200   LIND=LIND+1
31559         IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
31560         CHIND=' '
31561         CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
31562         READ(CHIND,'(I8)') I3
31563         LNAM=LIND+1
31564         NINDX=3
31565       ENDIF
31566
31567 C...Check that indices allowed.
31568       IERR=0
31569       IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
31570       IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
31571      &IERR=2
31572       IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
31573      &IERR=3
31574       IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
31575      &IERR=4
31576       IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
31577       IF(IERR.GE.1) THEN
31578         CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
31579      &  CHBIT(1:LNAM-1))
31580         LLOW=LHIG
31581         IF(LLOW.LT.LTOT) GOTO 120
31582         RETURN
31583       ENDIF
31584
31585 C...Save old value of variable.
31586       IF(IVAR.EQ.1) THEN
31587         IOLD=N
31588       ELSEIF(IVAR.EQ.2) THEN
31589         IOLD=K(I1,I2)
31590       ELSEIF(IVAR.EQ.3) THEN
31591         ROLD=P(I1,I2)
31592       ELSEIF(IVAR.EQ.4) THEN
31593         ROLD=V(I1,I2)
31594       ELSEIF(IVAR.EQ.5) THEN
31595         IOLD=MSTU(I1)
31596       ELSEIF(IVAR.EQ.6) THEN
31597         ROLD=PARU(I1)
31598       ELSEIF(IVAR.EQ.7) THEN
31599         IOLD=MSTJ(I1)
31600       ELSEIF(IVAR.EQ.8) THEN
31601         ROLD=PARJ(I1)
31602       ELSEIF(IVAR.EQ.9) THEN
31603         IOLD=KCHG(I1,I2)
31604       ELSEIF(IVAR.EQ.10) THEN
31605         ROLD=PMAS(I1,I2)
31606       ELSEIF(IVAR.EQ.11) THEN
31607         ROLD=PARF(I1)
31608       ELSEIF(IVAR.EQ.12) THEN
31609         ROLD=VCKM(I1,I2)
31610       ELSEIF(IVAR.EQ.13) THEN
31611         IOLD=MDCY(I1,I2)
31612       ELSEIF(IVAR.EQ.14) THEN
31613         IOLD=MDME(I1,I2)
31614       ELSEIF(IVAR.EQ.15) THEN
31615         ROLD=BRAT(I1)
31616       ELSEIF(IVAR.EQ.16) THEN
31617         IOLD=KFDP(I1,I2)
31618       ELSEIF(IVAR.EQ.17) THEN
31619         CHOLD=CHAF(I1,I2)
31620       ELSEIF(IVAR.EQ.18) THEN
31621         IOLD=MRPY(I1)
31622       ELSEIF(IVAR.EQ.19) THEN
31623         ROLD=RRPY(I1)
31624       ELSEIF(IVAR.EQ.20) THEN
31625         IOLD=MSEL
31626       ELSEIF(IVAR.EQ.21) THEN
31627         IOLD=MSUB(I1)
31628       ELSEIF(IVAR.EQ.22) THEN
31629         IOLD=KFIN(I1,I2)
31630       ELSEIF(IVAR.EQ.23) THEN
31631         ROLD=CKIN(I1)
31632       ELSEIF(IVAR.EQ.24) THEN
31633         IOLD=MSTP(I1)
31634       ELSEIF(IVAR.EQ.25) THEN
31635         ROLD=PARP(I1)
31636       ELSEIF(IVAR.EQ.26) THEN
31637         IOLD=MSTI(I1)
31638       ELSEIF(IVAR.EQ.27) THEN
31639         ROLD=PARI(I1)
31640       ELSEIF(IVAR.EQ.28) THEN
31641         IOLD=MINT(I1)
31642       ELSEIF(IVAR.EQ.29) THEN
31643         ROLD=VINT(I1)
31644       ELSEIF(IVAR.EQ.30) THEN
31645         IOLD=ISET(I1)
31646       ELSEIF(IVAR.EQ.31) THEN
31647         IOLD=KFPR(I1,I2)
31648       ELSEIF(IVAR.EQ.32) THEN
31649         ROLD=COEF(I1,I2)
31650       ELSEIF(IVAR.EQ.33) THEN
31651         IOLD=ICOL(I1,I2,I3)
31652       ELSEIF(IVAR.EQ.34) THEN
31653         ROLD=XSFX(I1,I2)
31654       ELSEIF(IVAR.EQ.35) THEN
31655         IOLD=ISIG(I1,I2)
31656       ELSEIF(IVAR.EQ.36) THEN
31657         ROLD=SIGH(I1)
31658       ELSEIF(IVAR.EQ.37) THEN
31659         IOLD=MWID(I1)
31660       ELSEIF(IVAR.EQ.38) THEN
31661         ROLD=WIDS(I1,I2)
31662       ELSEIF(IVAR.EQ.39) THEN
31663         IOLD=NGEN(I1,I2)
31664       ELSEIF(IVAR.EQ.40) THEN
31665         ROLD=XSEC(I1,I2)
31666       ELSEIF(IVAR.EQ.41) THEN
31667         CHOLD2=PROC(I1)
31668       ELSEIF(IVAR.EQ.42) THEN
31669         ROLD=SIGT(I1,I2,I3)
31670       ELSEIF(IVAR.EQ.43) THEN
31671         ROLD=XPVMD(I1)
31672       ELSEIF(IVAR.EQ.44) THEN
31673         ROLD=XPANL(I1)
31674       ELSEIF(IVAR.EQ.45) THEN
31675         ROLD=XPANH(I1)
31676       ELSEIF(IVAR.EQ.46) THEN
31677         ROLD=XPBEH(I1)
31678       ELSEIF(IVAR.EQ.47) THEN
31679         ROLD=XPDIR(I1)
31680       ELSEIF(IVAR.EQ.48) THEN
31681         IOLD=IMSS(I1)
31682       ELSEIF(IVAR.EQ.49) THEN
31683         ROLD=RMSS(I1)
31684       ENDIF
31685
31686 C...Print current value of variable. Loop back.
31687       IF(LNAM.GE.LBIT) THEN
31688         CHBIT(LNAM:14)=' '
31689         CHBIT(15:60)=' has the value                                '
31690         IF(MSVAR(IVAR,1).EQ.1) THEN
31691           WRITE(CHBIT(51:60),'(I10)') IOLD
31692         ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31693           WRITE(CHBIT(47:60),'(F14.5)') ROLD
31694         ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31695           CHBIT(53:60)=CHOLD
31696         ELSE
31697           CHBIT(33:60)=CHOLD
31698         ENDIF
31699         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31700         LLOW=LHIG
31701         IF(LLOW.LT.LTOT) GOTO 120
31702         RETURN
31703       ENDIF
31704
31705 C...Read in new variable value.
31706       IF(MSVAR(IVAR,1).EQ.1) THEN
31707         CHINI=' '
31708         CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
31709         READ(CHINI,'(I10)') INEW
31710       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31711         CHINR=' '
31712         CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
31713         READ(CHINR,*) RNEW
31714       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31715         CHNEW=CHBIT(LNAM+1:LBIT)//' '
31716       ELSE
31717         CHNEW2=CHBIT(LNAM+1:LBIT)//' '
31718       ENDIF
31719
31720 C...Store new variable value.
31721       IF(IVAR.EQ.1) THEN
31722         N=INEW
31723       ELSEIF(IVAR.EQ.2) THEN
31724         K(I1,I2)=INEW
31725       ELSEIF(IVAR.EQ.3) THEN
31726         P(I1,I2)=RNEW
31727       ELSEIF(IVAR.EQ.4) THEN
31728         V(I1,I2)=RNEW
31729       ELSEIF(IVAR.EQ.5) THEN
31730         MSTU(I1)=INEW
31731       ELSEIF(IVAR.EQ.6) THEN
31732         PARU(I1)=RNEW
31733       ELSEIF(IVAR.EQ.7) THEN
31734         MSTJ(I1)=INEW
31735       ELSEIF(IVAR.EQ.8) THEN
31736         PARJ(I1)=RNEW
31737       ELSEIF(IVAR.EQ.9) THEN
31738         KCHG(I1,I2)=INEW
31739       ELSEIF(IVAR.EQ.10) THEN
31740         PMAS(I1,I2)=RNEW
31741       ELSEIF(IVAR.EQ.11) THEN
31742         PARF(I1)=RNEW
31743       ELSEIF(IVAR.EQ.12) THEN
31744         VCKM(I1,I2)=RNEW
31745       ELSEIF(IVAR.EQ.13) THEN
31746         MDCY(I1,I2)=INEW
31747       ELSEIF(IVAR.EQ.14) THEN
31748         MDME(I1,I2)=INEW
31749       ELSEIF(IVAR.EQ.15) THEN
31750         BRAT(I1)=RNEW
31751       ELSEIF(IVAR.EQ.16) THEN
31752         KFDP(I1,I2)=INEW
31753       ELSEIF(IVAR.EQ.17) THEN
31754         CHAF(I1,I2)=CHNEW
31755       ELSEIF(IVAR.EQ.18) THEN
31756         MRPY(I1)=INEW
31757       ELSEIF(IVAR.EQ.19) THEN
31758         RRPY(I1)=RNEW
31759       ELSEIF(IVAR.EQ.20) THEN
31760         MSEL=INEW
31761       ELSEIF(IVAR.EQ.21) THEN
31762         MSUB(I1)=INEW
31763       ELSEIF(IVAR.EQ.22) THEN
31764         KFIN(I1,I2)=INEW
31765       ELSEIF(IVAR.EQ.23) THEN
31766         CKIN(I1)=RNEW
31767       ELSEIF(IVAR.EQ.24) THEN
31768         MSTP(I1)=INEW
31769       ELSEIF(IVAR.EQ.25) THEN
31770         PARP(I1)=RNEW
31771       ELSEIF(IVAR.EQ.26) THEN
31772         MSTI(I1)=INEW
31773       ELSEIF(IVAR.EQ.27) THEN
31774         PARI(I1)=RNEW
31775       ELSEIF(IVAR.EQ.28) THEN
31776         MINT(I1)=INEW
31777       ELSEIF(IVAR.EQ.29) THEN
31778         VINT(I1)=RNEW
31779       ELSEIF(IVAR.EQ.30) THEN
31780         ISET(I1)=INEW
31781       ELSEIF(IVAR.EQ.31) THEN
31782         KFPR(I1,I2)=INEW
31783       ELSEIF(IVAR.EQ.32) THEN
31784         COEF(I1,I2)=RNEW
31785       ELSEIF(IVAR.EQ.33) THEN
31786         ICOL(I1,I2,I3)=INEW
31787       ELSEIF(IVAR.EQ.34) THEN
31788         XSFX(I1,I2)=RNEW
31789       ELSEIF(IVAR.EQ.35) THEN
31790         ISIG(I1,I2)=INEW
31791       ELSEIF(IVAR.EQ.36) THEN
31792         SIGH(I1)=RNEW
31793       ELSEIF(IVAR.EQ.37) THEN
31794         MWID(I1)=INEW
31795       ELSEIF(IVAR.EQ.38) THEN
31796         WIDS(I1,I2)=RNEW
31797       ELSEIF(IVAR.EQ.39) THEN
31798         NGEN(I1,I2)=INEW
31799       ELSEIF(IVAR.EQ.40) THEN
31800         XSEC(I1,I2)=RNEW
31801       ELSEIF(IVAR.EQ.41) THEN
31802         PROC(I1)=CHNEW2
31803       ELSEIF(IVAR.EQ.42) THEN
31804         SIGT(I1,I2,I3)=RNEW
31805       ELSEIF(IVAR.EQ.43) THEN
31806         XPVMD(I1)=RNEW
31807       ELSEIF(IVAR.EQ.44) THEN
31808         XPANL(I1)=RNEW
31809       ELSEIF(IVAR.EQ.45) THEN
31810         XPANH(I1)=RNEW
31811       ELSEIF(IVAR.EQ.46) THEN
31812         XPBEH(I1)=RNEW
31813       ELSEIF(IVAR.EQ.47) THEN
31814         XPDIR(I1)=RNEW
31815       ELSEIF(IVAR.EQ.48) THEN
31816         IMSS(I1)=INEW
31817       ELSEIF(IVAR.EQ.49) THEN
31818         RMSS(I1)=RNEW
31819       ENDIF
31820
31821 C...Write old and new value. Loop back.
31822       CHBIT(LNAM:14)=' '
31823       CHBIT(15:60)=' changed from                to               '
31824       IF(MSVAR(IVAR,1).EQ.1) THEN
31825         WRITE(CHBIT(33:42),'(I10)') IOLD
31826         WRITE(CHBIT(51:60),'(I10)') INEW
31827         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31828       ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
31829         WRITE(CHBIT(29:42),'(F14.5)') ROLD
31830         WRITE(CHBIT(47:60),'(F14.5)') RNEW
31831         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31832       ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
31833         CHBIT(35:42)=CHOLD
31834         CHBIT(53:60)=CHNEW
31835         IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
31836       ELSE
31837         CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
31838         IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
31839       ENDIF
31840       LLOW=LHIG
31841       IF(LLOW.LT.LTOT) GOTO 120
31842
31843 C...Format statement for output on unit MSTU(11) (by default 6).
31844  5000 FORMAT(5X,A60)
31845  5100 FORMAT(5X,A88)
31846
31847       RETURN
31848       END
31849
31850 C*********************************************************************
31851
31852 *$ CREATE PYEXEC.FOR
31853 *COPY PYEXEC
31854 C...PYEXEC
31855 C...Administrates the fragmentation and decay chain.
31856
31857       SUBROUTINE PYEXEC
31858
31859 C...Double precision and integer declarations.
31860       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31861       INTEGER PYK,PYCHGE,PYCOMP
31862 C...Commonblocks.
31863       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
31864       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31865       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31866       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
31867       COMMON/PYINT4/MWID(500),WIDS(500,5)
31868       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/
31869 C...Local array.
31870       DIMENSION PS(2,6),IJOIN(100)
31871
31872 C...Initialize and reset.
31873       MSTU(24)=0
31874       IF(MSTU(12).GE.1) CALL PYLIST(0)
31875       MSTU(31)=MSTU(31)+1
31876       MSTU(1)=0
31877       MSTU(2)=0
31878       MSTU(3)=0
31879       IF(MSTU(17).LE.0) MSTU(90)=0
31880       MCONS=1
31881
31882 C...Sum up momentum, energy and charge for starting entries.
31883       NSAV=N
31884       DO 110 I=1,2
31885         DO 100 J=1,6
31886           PS(I,J)=0D0
31887   100   CONTINUE
31888   110 CONTINUE
31889       DO 130 I=1,N
31890         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
31891         DO 120 J=1,4
31892           PS(1,J)=PS(1,J)+P(I,J)
31893   120   CONTINUE
31894         PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
31895   130 CONTINUE
31896       PARU(21)=PS(1,4)
31897
31898 C...Prepare system for subsequent fragmentation/decay.
31899       CALL PYPREP(0)
31900
31901 C...Loop through jet fragmentation and particle decays.
31902       MBE=0
31903   140 MBE=MBE+1
31904       IP=0
31905   150 IP=IP+1
31906       KC=0
31907       IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
31908       IF(KC.EQ.0) THEN
31909
31910 C...Deal with any remaining undecayed resonance
31911 C...(normally the task of PYEVNT, so seldom used).
31912       ELSEIF(MWID(KC).NE.0) THEN
31913         IBEG=IP
31914         IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
31915           IBEG=IP+1
31916   160     IBEG=IBEG-1
31917           IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160
31918           IF(K(IBEG,1).NE.2) IBEG=IBEG+1
31919           IEND=IP-1
31920   170     IEND=IEND+1
31921           IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170
31922           IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170
31923           NJOIN=0
31924           DO 180 I=IBEG,IEND
31925             IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
31926               NJOIN=NJOIN+1
31927               IJOIN(NJOIN)=I
31928             ENDIF
31929   180     CONTINUE
31930         ENDIF
31931         CALL PYRESD(IP)
31932         CALL PYPREP(IBEG)
31933
31934 C...Particle decay if unstable and allowed. Save long-lived particle
31935 C...decays until second pass after Bose-Einstein effects.
31936       ELSEIF(KCHG(KC,2).EQ.0) THEN
31937         IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
31938      &  .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
31939      &  CALL PYDECY(IP)
31940
31941 C...Decay products may develop a shower.
31942         IF(MSTJ(92).GT.0) THEN
31943           IP1=MSTJ(92)
31944           QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
31945      &    1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
31946           CALL PYSHOW(IP1,IP1+1,QMAX)
31947           CALL PYPREP(IP1)
31948           MSTJ(92)=0
31949         ELSEIF(MSTJ(92).LT.0) THEN
31950           IP1=-MSTJ(92)
31951           CALL PYSHOW(IP1,-3,P(IP,5))
31952           CALL PYPREP(IP1)
31953           MSTJ(92)=0
31954         ENDIF
31955
31956 C...Jet fragmentation: string or independent fragmentation.
31957       ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
31958         MFRAG=MSTJ(1)
31959         IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
31960         IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
31961           IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
31962      &    K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
31963             IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
31964           ENDIF
31965         ENDIF
31966         IF(MFRAG.EQ.1) CALL PYSTRF(IP)
31967         IF(MFRAG.EQ.2) CALL PYINDF(IP)
31968         IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
31969         IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
31970       ENDIF
31971
31972 C...Loop back if enough space left in PYJETS and no error abort.
31973       IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
31974       ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
31975         GOTO 150
31976       ELSEIF(IP.LT.N) THEN
31977         CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
31978       ENDIF
31979
31980 C...Include simple Bose-Einstein effect parametrization if desired.
31981       IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
31982         CALL PYBOEI(NSAV)
31983         GOTO 140
31984       ENDIF
31985
31986 C...Check that momentum, energy and charge were conserved.
31987       DO 200 I=1,N
31988         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200
31989         DO 190 J=1,4
31990           PS(2,J)=PS(2,J)+P(I,J)
31991   190   CONTINUE
31992         PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
31993   200 CONTINUE
31994       PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
31995      &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
31996       IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
31997      &'(PYEXEC:) four-momentum was not conserved')
31998       IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
31999      &'(PYEXEC:) charge was not conserved')
32000
32001       RETURN
32002       END
32003
32004 C*********************************************************************
32005
32006 *$ CREATE PYPREP.FOR
32007 *COPY PYPREP
32008 C...PYPREP
32009 C...Rearranges partons along strings. Allows small systems
32010 C...to collapse into one or two particles and checks flavours.
32011
32012       SUBROUTINE PYPREP(IP)
32013
32014 C...Double precision and integer declarations.
32015       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32016       INTEGER PYK,PYCHGE,PYCOMP
32017 C...Commonblocks.
32018       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32019       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32020       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32021       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
32022       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
32023 C...Local arrays.
32024       DIMENSION DPS(5),DPC(5),UE(3)
32025
32026 C...Rearrange parton shower product listing along strings: begin loop.
32027       I1=N
32028       DO 130 MQGST=1,2
32029         DO 120 I=MAX(1,IP),N
32030           IF(K(I,1).NE.3) GOTO 120
32031           KC=PYCOMP(K(I,2))
32032           IF(KC.EQ.0) GOTO 120
32033           KQ=KCHG(KC,2)
32034           IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120
32035
32036 C...Pick up loose string end.
32037           KCS=4
32038           IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
32039           IA=I
32040           NSTP=0
32041   100     NSTP=NSTP+1
32042           IF(NSTP.GT.4*N) THEN
32043             CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
32044             RETURN
32045           ENDIF
32046
32047 C...Copy undecayed parton.
32048           IF(K(IA,1).EQ.3) THEN
32049             IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN
32050               CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
32051               RETURN
32052             ENDIF
32053             I1=I1+1
32054             K(I1,1)=2
32055             IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
32056             K(I1,2)=K(IA,2)
32057             K(I1,3)=IA
32058             K(I1,4)=0
32059             K(I1,5)=0
32060             DO 110 J=1,5
32061               P(I1,J)=P(IA,J)
32062               V(I1,J)=V(IA,J)
32063   110       CONTINUE
32064             K(IA,1)=K(IA,1)+10
32065             IF(K(I1,1).EQ.1) GOTO 120
32066           ENDIF
32067
32068 C...Go to next parton in colour space.
32069           IB=IA
32070           IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
32071      &    .NE.0) THEN
32072             IA=MOD(K(IB,KCS),MSTU(5))
32073             K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
32074             MREV=0
32075           ELSE
32076             IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
32077      &      MSTU(5)).EQ.0) KCS=9-KCS
32078             IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
32079             K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
32080             MREV=1
32081           ENDIF
32082           IF(IA.LE.0.OR.IA.GT.N) THEN
32083             CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
32084             RETURN
32085           ENDIF
32086           IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
32087      &    MSTU(5)).EQ.IB) THEN
32088             IF(MREV.EQ.1) KCS=9-KCS
32089             IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
32090             K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
32091           ELSE
32092             IF(MREV.EQ.0) KCS=9-KCS
32093             IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
32094             K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
32095           ENDIF
32096           IF(IA.NE.I) GOTO 100
32097           K(I1,1)=1
32098   120   CONTINUE
32099   130 CONTINUE
32100       N=I1
32101       IF(MSTJ(14).LT.0) RETURN
32102
32103 C...Find lowest-mass colour singlet jet system, OK if above threshold.
32104       IF(MSTJ(14).EQ.0) GOTO 320
32105       NS=N
32106   140 NSIN=N-NS
32107       PDM=1D0+PARJ(32)
32108       IC=0
32109       DO 190 I=MAX(1,IP),NS
32110         IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
32111         ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
32112           NSIN=NSIN+1
32113           IC=I
32114           DO 150 J=1,4
32115             DPS(J)=P(I,J)
32116   150     CONTINUE
32117           MSTJ(93)=1
32118           DPS(5)=PYMASS(K(I,2))
32119         ELSEIF(K(I,1).EQ.2) THEN
32120           DO 160 J=1,4
32121             DPS(J)=DPS(J)+P(I,J)
32122   160     CONTINUE
32123         ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
32124           DO 170 J=1,4
32125             DPS(J)=DPS(J)+P(I,J)
32126   170     CONTINUE
32127           MSTJ(93)=1
32128           DPS(5)=DPS(5)+PYMASS(K(I,2))
32129           PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
32130      &    DPS(5)
32131           IF(PD.LT.PDM) THEN
32132             PDM=PD
32133             DO 180 J=1,5
32134               DPC(J)=DPS(J)
32135   180       CONTINUE
32136             IC1=IC
32137             IC2=I
32138           ENDIF
32139           IC=0
32140         ELSE
32141           NSIN=NSIN+1
32142         ENDIF
32143   190 CONTINUE
32144       IF(PDM.GE.PARJ(32)) GOTO 320
32145
32146 C...Fill small-mass system as cluster.
32147       NSAV=N
32148       PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
32149       K(N+1,1)=11
32150       K(N+1,2)=91
32151       K(N+1,3)=IC1
32152       K(N+1,4)=N+2
32153       K(N+1,5)=N+3
32154       P(N+1,1)=DPC(1)
32155       P(N+1,2)=DPC(2)
32156       P(N+1,3)=DPC(3)
32157       P(N+1,4)=DPC(4)
32158       P(N+1,5)=PECM
32159
32160 C...Form two particles from flavours of lowest-mass system, if feasible.
32161       K(N+2,1)=1
32162       K(N+3,1)=1
32163       IF(MSTU(16).NE.2) THEN
32164         K(N+2,3)=N+1
32165         K(N+3,3)=N+1
32166       ELSE
32167         K(N+2,3)=IC1
32168         K(N+3,3)=IC2
32169       ENDIF
32170       K(N+2,4)=0
32171       K(N+3,4)=0
32172       K(N+2,5)=0
32173       K(N+3,5)=0
32174       IF(IABS(K(IC1,2)).NE.21) THEN
32175         KC1=PYCOMP(K(IC1,2))
32176         KC2=PYCOMP(K(IC2,2))
32177         IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320
32178         KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
32179         KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
32180         IF(KQ1+KQ2.NE.0) GOTO 320
32181 C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson
32182   200   K1=K(IC1,2)
32183         IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
32184         MSTU(125)=0
32185         CALL PYDCYK(K1,0,KFLN,K(N+2,2))
32186         CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
32187         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200
32188       ELSE
32189         IF(IABS(K(IC2,2)).NE.21) GOTO 320
32190 C.. No room for popcorn mesons in closed string -> 2 hadrons.
32191         MSTU(125)=0
32192   210   CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
32193         CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
32194         CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
32195         IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
32196       ENDIF
32197       P(N+2,5)=PYMASS(K(N+2,2))
32198       P(N+3,5)=PYMASS(K(N+3,2))
32199       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320
32200       IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260
32201
32202 C...Perform two-particle decay of jet system, if possible.
32203       IF(PECM.GE.0.02D0*DPC(4)) THEN
32204         PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
32205      &  (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
32206         UE(3)=2D0*PYR(0)-1D0
32207         PHI=PARU(2)*PYR(0)
32208         UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
32209         UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
32210         DO 220 J=1,3
32211           P(N+2,J)=PA*UE(J)
32212           P(N+3,J)=-PA*UE(J)
32213   220   CONTINUE
32214         P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
32215         P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
32216         MSTU(33)=1
32217         CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4),
32218      &  DPC(3)/DPC(4))
32219       ELSE
32220         NP=0
32221         DO 230 I=IC1,IC2
32222           IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1
32223   230   CONTINUE
32224         HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)-
32225      &  P(IC1,3)*P(IC2,3)
32226         IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260
32227         HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2)
32228         HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2)
32229         HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/
32230      &  (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0
32231         HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2
32232         HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC
32233         HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC
32234         DO 240 J=1,4
32235           P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J)
32236           P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J)
32237   240   CONTINUE
32238       ENDIF
32239       DO 250 J=1,4
32240         V(N+1,J)=V(IC1,J)
32241         V(N+2,J)=V(IC1,J)
32242         V(N+3,J)=V(IC2,J)
32243   250 CONTINUE
32244       V(N+1,5)=0D0
32245       V(N+2,5)=0D0
32246       V(N+3,5)=0D0
32247       N=N+3
32248       GOTO 300
32249
32250 C...Else form one particle from the flavours available, if possible.
32251   260 K(N+1,5)=N+2
32252       IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
32253         GOTO 320
32254       ELSEIF(IABS(K(IC1,2)).NE.21) THEN
32255         CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2))
32256       ELSE
32257         KFLN=1+INT((2D0+PARJ(2))*PYR(0))
32258         CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
32259       ENDIF
32260       IF(K(N+2,2).EQ.0) GOTO 260
32261       P(N+2,5)=PYMASS(K(N+2,2))
32262
32263 C...Find parton/particle which combines to largest extra mass.
32264       IR=0
32265       HA=0D0
32266       HSM=0D0
32267       DO 280 MCOMB=1,3
32268         IF(IR.NE.0) GOTO 280
32269         DO 270 I=MAX(1,IP),N
32270           IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
32271      &    .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270
32272           IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
32273           IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270
32274           IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270
32275           IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
32276      &    GOTO 270
32277           HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
32278           HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
32279           IF(HSR.GT.HSM) THEN
32280             IR=I
32281             HA=HCR
32282             HSM=HSR
32283           ENDIF
32284   270   CONTINUE
32285   280 CONTINUE
32286
32287 C...Shuffle energy and momentum to put new particle on mass shell.
32288       IF(IR.NE.0) THEN
32289         HB=PECM**2+HA
32290         HC=P(N+2,5)**2+HA
32291         HD=P(IR,5)**2+HA
32292         HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
32293      &  (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
32294         HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
32295         DO 290 J=1,4
32296           P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
32297           P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
32298           V(N+1,J)=V(IC1,J)
32299           V(N+2,J)=V(IC1,J)
32300   290   CONTINUE
32301         V(N+1,5)=0D0
32302         V(N+2,5)=0D0
32303         N=N+2
32304       ELSE
32305         CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
32306         RETURN
32307       ENDIF
32308
32309 C...Mark collapsed system and store daughter pointers. Iterate.
32310   300 DO 310 I=IC1,IC2
32311         IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0)
32312      &  THEN
32313           K(I,1)=K(I,1)+10
32314           IF(MSTU(16).NE.2) THEN
32315             K(I,4)=NSAV+1
32316             K(I,5)=NSAV+1
32317           ELSE
32318             K(I,4)=NSAV+2
32319             K(I,5)=N
32320           ENDIF
32321         ENDIF
32322   310 CONTINUE
32323       IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
32324
32325 C...Check flavours and invariant masses in parton systems.
32326   320 NP=0
32327       KFN=0
32328       KQS=0
32329       DO 330 J=1,5
32330         DPS(J)=0D0
32331   330 CONTINUE
32332       DO 360 I=MAX(1,IP),N
32333         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360
32334         KC=PYCOMP(K(I,2))
32335         IF(KC.EQ.0) GOTO 360
32336         KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32337         IF(KQ.EQ.0) GOTO 360
32338         NP=NP+1
32339         IF(KQ.NE.2) THEN
32340           KFN=KFN+1
32341           KQS=KQS+KQ
32342           MSTJ(93)=1
32343           DPS(5)=DPS(5)+PYMASS(K(I,2))
32344         ENDIF
32345         DO 340 J=1,4
32346           DPS(J)=DPS(J)+P(I,J)
32347   340   CONTINUE
32348         IF(K(I,1).EQ.1) THEN
32349           IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL
32350      &    PYERRM(2,'(PYPREP:) unphysical flavour combination')
32351           IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32352      &    (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
32353      &    '(PYPREP:) too small mass in jet system')
32354 **sr
32355 C         IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
32356 C    &    (0.9D0*PARJ(32)+DPS(5))**2)
32357 C    &    WRITE(*,*) 'I,DPS',I,DPS
32358 **
32359           NP=0
32360           KFN=0
32361           KQS=0
32362           DO 350 J=1,5
32363             DPS(J)=0D0
32364   350     CONTINUE
32365         ENDIF
32366   360 CONTINUE
32367
32368       RETURN
32369       END
32370
32371 C*********************************************************************
32372
32373 *$ CREATE PYSTRF.FOR
32374 *COPY PYSTRF
32375 C...PYSTRF
32376 C...Handles the fragmentation of an arbitrary colour singlet
32377 C...jet system according to the Lund string fragmentation model.
32378
32379       SUBROUTINE PYSTRF(IP)
32380
32381 C...Double precision and integer declarations.
32382       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32383       INTEGER PYK,PYCHGE,PYCOMP
32384 C...Commonblocks.
32385       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
32386       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32387       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32388       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
32389 C...Local arrays. All MOPS variables ends with MO
32390       DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
32391      &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
32392      &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
32393      &INMO(9),PM2QMO(2),XTMO(2)
32394
32395 C...Function: four-product of two vectors.
32396       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)
32397       DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
32398      &DP(I,3)*DP(J,3)
32399
32400 C...Reset counters. Identify parton system.
32401       MSTJ(91)=0
32402       NSAV=N
32403       MSTU90=MSTU(90)
32404       NP=0
32405       KQSUM=0
32406       DO 100 J=1,5
32407         DPS(J)=0D0
32408   100 CONTINUE
32409       MJU(1)=0
32410       MJU(2)=0
32411       I=IP-1
32412   110 I=I+1
32413       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
32414         CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
32415         IF(MSTU(21).GE.1) RETURN
32416       ENDIF
32417       IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
32418       KC=PYCOMP(K(I,2))
32419       IF(KC.EQ.0) GOTO 110
32420       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
32421       IF(KQ.EQ.0) GOTO 110
32422       IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
32423         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32424         IF(MSTU(21).GE.1) RETURN
32425       ENDIF
32426
32427 C...Take copy of partons to be considered. Check flavour sum.
32428       NP=NP+1
32429       DO 120 J=1,5
32430         K(N+NP,J)=K(I,J)
32431         P(N+NP,J)=P(I,J)
32432         IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
32433   120 CONTINUE
32434       DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
32435       K(N+NP,3)=I
32436       IF(KQ.NE.2) KQSUM=KQSUM+KQ
32437       IF(K(I,1).EQ.41) THEN
32438         KQSUM=KQSUM+2*KQ
32439         IF(KQSUM.EQ.KQ) MJU(1)=N+NP
32440         IF(KQSUM.NE.KQ) MJU(2)=N+NP
32441       ENDIF
32442       IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
32443       IF(KQSUM.NE.0) THEN
32444         CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32445         IF(MSTU(21).GE.1) RETURN
32446       ENDIF
32447
32448 C...Boost copied system to CM frame (for better numerical precision).
32449       IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
32450         MBST=0
32451         MSTU(33)=1
32452         CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
32453      &  -DPS(3)/DPS(4))
32454       ELSE
32455         MBST=1
32456         HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
32457         DO 130 I=N+1,N+NP
32458           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
32459           IF(P(I,3).GT.0D0) THEN
32460             HHPEZ=(P(I,4)+P(I,3))/HHBZ
32461             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
32462             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32463           ELSE
32464             HHPEZ=(P(I,4)-P(I,3))*HHBZ
32465             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
32466             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
32467           ENDIF
32468   130   CONTINUE
32469       ENDIF
32470
32471 C...Search for very nearby partons that may be recombined.
32472       NTRYR=0
32473       PARU12=PARU(12)
32474       PARU13=PARU(13)
32475       MJU(3)=MJU(1)
32476       MJU(4)=MJU(2)
32477       NR=NP
32478   140 IF(NR.GE.3) THEN
32479         PDRMIN=2D0*PARU12
32480         DO 150 I=N+1,N+NR
32481           IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
32482           I1=I+1
32483           IF(I.EQ.N+NR) I1=N+1
32484           IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
32485           IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
32486      &    GOTO 150
32487           IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
32488      &    GOTO 150
32489           PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
32490      &    P(I1,2)**2+P(I1,3)**2))
32491           PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
32492           PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
32493           IF(PDR.LT.PDRMIN) THEN
32494             IR=I
32495             PDRMIN=PDR
32496           ENDIF
32497   150   CONTINUE
32498
32499 C...Recombine very nearby partons to avoid machine precision problems.
32500         IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
32501           DO 160 J=1,4
32502             P(N+1,J)=P(N+1,J)+P(N+NR,J)
32503   160     CONTINUE
32504           P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
32505      &    P(N+1,3)**2))
32506           NR=NR-1
32507           GOTO 140
32508         ELSEIF(PDRMIN.LT.PARU12) THEN
32509           DO 170 J=1,4
32510             P(IR,J)=P(IR,J)+P(IR+1,J)
32511   170     CONTINUE
32512           P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
32513      &    P(IR,3)**2))
32514           DO 190 I=IR+1,N+NR-1
32515             K(I,2)=K(I+1,2)
32516             DO 180 J=1,5
32517               P(I,J)=P(I+1,J)
32518   180       CONTINUE
32519   190     CONTINUE
32520           IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
32521           NR=NR-1
32522           IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
32523           IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
32524           GOTO 140
32525         ENDIF
32526       ENDIF
32527       NTRYR=NTRYR+1
32528
32529 C...Reset particle counter. Skip ahead if no junctions are present;
32530 C...this is usually the case!
32531       NRS=MAX(5*NR+11,NP)
32532       NTRY=0
32533   200 NTRY=NTRY+1
32534       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32535         PARU12=4D0*PARU12
32536         PARU13=2D0*PARU13
32537         GOTO 140
32538       ELSEIF(NTRY.GT.100) THEN
32539         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32540         IF(MSTU(21).GE.1) RETURN
32541       ENDIF
32542       I=N+NRS
32543       MSTU(90)=MSTU90
32544       IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580
32545       IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
32546      &     ' junction strings not handled by MSTJ(12)>3 options')
32547       DO 570 JT=1,2
32548         NJS(JT)=0
32549         IF(MJU(JT).EQ.0) GOTO 570
32550         JS=3-2*JT
32551
32552 C...Find and sum up momentum on three sides of junction. Check flavours.
32553         DO 220 IU=1,3
32554           IJU(IU)=0
32555           DO 210 J=1,5
32556             PJU(IU,J)=0D0
32557   210     CONTINUE
32558   220   CONTINUE
32559         IU=0
32560         DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS
32561           IF(K(I1,2).NE.21.AND.IU.LE.2) THEN
32562             IU=IU+1
32563             IJU(IU)=I1
32564           ENDIF
32565           DO 230 J=1,4
32566             PJU(IU,J)=PJU(IU,J)+P(I1,J)
32567   230     CONTINUE
32568   240   CONTINUE
32569         DO 250 IU=1,3
32570           PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
32571   250   CONTINUE
32572         IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND.
32573      &  K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN
32574           CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
32575           IF(MSTU(21).GE.1) RETURN
32576         ENDIF
32577
32578 C...Calculate (approximate) boost to rest frame of junction.
32579         T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/
32580      &  (PJU(1,5)*PJU(2,5))
32581         T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/
32582      &  (PJU(1,5)*PJU(3,5))
32583         T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/
32584      &  (PJU(2,5)*PJU(3,5))
32585         T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23))
32586         T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13))
32587         TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12))
32588         T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2)
32589         T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2)
32590         DO 260 J=1,3
32591           TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5))
32592   260   CONTINUE
32593         TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
32594         DO 270 IU=1,3
32595           PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
32596      &    TJU(3)*PJU(IU,3)
32597   270   CONTINUE
32598
32599 C...Put junction at rest if motion could give inconsistencies.
32600         IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN
32601           DO 280 J=1,3
32602             TJU(J)=0D0
32603   280     CONTINUE
32604           TJU(4)=1D0
32605           PJU(1,5)=PJU(1,4)
32606           PJU(2,5)=PJU(2,4)
32607           PJU(3,5)=PJU(3,4)
32608         ENDIF
32609
32610 C...Start preparing for fragmentation of two strings from junction.
32611         ISTA=I
32612         DO 550 IU=1,2
32613           NS=IJU(IU+1)-IJU(IU)
32614
32615 C...Junction strings: find longitudinal string directions.
32616           DO 310 IS=1,NS
32617             IS1=IJU(IU)+IS-1
32618             IS2=IJU(IU)+IS
32619             DO 290 J=1,5
32620               DP(1,J)=0.5D0*P(IS1,J)
32621               IF(IS.EQ.1) DP(1,J)=P(IS1,J)
32622               DP(2,J)=0.5D0*P(IS2,J)
32623               IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J)
32624   290       CONTINUE
32625             IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+
32626      &      PJU(IU,3)**2)
32627             IF(IS.EQ.NS) DP(2,5)=0D0
32628             DP(3,5)=DFOUR(1,1)
32629             DP(4,5)=DFOUR(2,2)
32630             DHKC=DFOUR(1,2)
32631             IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32632               DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32633               DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32634               DP(3,5)=0D0
32635               DP(4,5)=0D0
32636               DHKC=DFOUR(1,2)
32637             ENDIF
32638             DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32639             DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32640             DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32641             IN1=N+NR+4*IS-3
32642             P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32643             DO 300 J=1,4
32644               P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32645               P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32646   300       CONTINUE
32647   310     CONTINUE
32648
32649 C...Junction strings: initialize flavour, momentum and starting pos.
32650           ISAV=I
32651           MSTU91=MSTU(90)
32652   320     NTRY=NTRY+1
32653           IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32654             PARU12=4D0*PARU12
32655             PARU13=2D0*PARU13
32656             GOTO 140
32657           ELSEIF(NTRY.GT.100) THEN
32658             CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
32659             IF(MSTU(21).GE.1) RETURN
32660           ENDIF
32661           I=ISAV
32662           MSTU(90)=MSTU91
32663           IRANKJ=0
32664           IE(1)=K(N+1+(JT/2)*(NP-1),3)
32665           IN(4)=N+NR+1
32666           IN(5)=IN(4)+1
32667           IN(6)=N+NR+4*NS+1
32668           DO 340 JQ=1,2
32669             DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
32670               P(IN1,1)=2-JQ
32671               P(IN1,2)=JQ-1
32672               P(IN1,3)=1D0
32673   330       CONTINUE
32674   340     CONTINUE
32675           KFL(1)=K(IJU(IU),2)
32676           PX(1)=0D0
32677           PY(1)=0D0
32678           GAM(1)=0D0
32679           DO 350 J=1,5
32680             PJU(IU+3,J)=0D0
32681   350     CONTINUE
32682
32683 C...Junction strings: find initial transverse directions.
32684           DO 360 J=1,4
32685             DP(1,J)=P(IN(4),J)
32686             DP(2,J)=P(IN(4)+1,J)
32687             DP(3,J)=0D0
32688             DP(4,J)=0D0
32689   360     CONTINUE
32690           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32691           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32692           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32693           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32694           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32695           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32696           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32697           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32698           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32699           DHC12=DFOUR(1,2)
32700           DHCX1=DFOUR(3,1)/DHC12
32701           DHCX2=DFOUR(3,2)/DHC12
32702           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32703           DHCY1=DFOUR(4,1)/DHC12
32704           DHCY2=DFOUR(4,2)/DHC12
32705           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32706           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32707           DO 370 J=1,4
32708             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32709             P(IN(6),J)=DP(3,J)
32710             P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32711      &      DHCYX*DP(3,J))
32712   370     CONTINUE
32713
32714 C...Junction strings: produce new particle, origin.
32715   380     I=I+1
32716           IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
32717             CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
32718             IF(MSTU(21).GE.1) RETURN
32719           ENDIF
32720           IRANKJ=IRANKJ+1
32721           K(I,1)=1
32722           K(I,3)=IE(1)
32723           K(I,4)=0
32724           K(I,5)=0
32725
32726 C...Junction strings: generate flavour, hadron, pT, z and Gamma.
32727   390     CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
32728           IF(K(I,2).EQ.0) GOTO 320
32729           IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
32730      &    IABS(KFL(3)).GT.10) THEN
32731             IF(PYR(0).GT.PARJ(19)) GOTO 390
32732           ENDIF
32733           P(I,5)=PYMASS(K(I,2))
32734           CALL PYPTDI(KFL(1),PX(3),PY(3))
32735           PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
32736           CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
32737           IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
32738      &    MSTU(90).LT.8) THEN
32739             MSTU(90)=MSTU(90)+1
32740             MSTU(90+MSTU(90))=I
32741             PARU(90+MSTU(90))=Z
32742           ENDIF
32743           GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
32744           DO 400 J=1,3
32745             IN(J)=IN(3+J)
32746   400     CONTINUE
32747
32748 C...Junction strings: stepping within or from 'low' string region easy.
32749           IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
32750      &    P(IN(1),5)**2.GE.PR(1)) THEN
32751             P(IN(1)+2,4)=Z*P(IN(1)+2,3)
32752             P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
32753             DO 410 J=1,4
32754               P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
32755   410       CONTINUE
32756             GOTO 500
32757           ELSEIF(IN(1)+1.EQ.IN(2)) THEN
32758             P(IN(2)+2,4)=P(IN(2)+2,3)
32759             P(IN(2)+2,1)=1D0
32760             IN(2)=IN(2)+4
32761             IF(IN(2).GT.N+NR+4*NS) GOTO 320
32762             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32763               P(IN(1)+2,4)=P(IN(1)+2,3)
32764               P(IN(1)+2,1)=0D0
32765               IN(1)=IN(1)+4
32766             ENDIF
32767           ENDIF
32768
32769 C...Junction strings: find new transverse directions.
32770   420     IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
32771      &    IN(1).GT.IN(2)) GOTO 320
32772           IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
32773             DO 430 J=1,4
32774               DP(1,J)=P(IN(1),J)
32775               DP(2,J)=P(IN(2),J)
32776               DP(3,J)=0D0
32777               DP(4,J)=0D0
32778   430       CONTINUE
32779             DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
32780             DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
32781             DHC12=DFOUR(1,2)
32782             IF(DHC12.LE.1D-2) THEN
32783               P(IN(1)+2,4)=P(IN(1)+2,3)
32784               P(IN(1)+2,1)=0D0
32785               IN(1)=IN(1)+4
32786               GOTO 420
32787             ENDIF
32788             IN(3)=N+NR+4*NS+5
32789             DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
32790             DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
32791             DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
32792             IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
32793             IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
32794             IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
32795             IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
32796             DHCX1=DFOUR(3,1)/DHC12
32797             DHCX2=DFOUR(3,2)/DHC12
32798             DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
32799             DHCY1=DFOUR(4,1)/DHC12
32800             DHCY2=DFOUR(4,2)/DHC12
32801             DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
32802             DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
32803             DO 440 J=1,4
32804               DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
32805               P(IN(3),J)=DP(3,J)
32806               P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
32807      &        DHCYX*DP(3,J))
32808   440       CONTINUE
32809 C...Express pT with respect to new axes, if sensible.
32810             PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
32811             PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
32812             IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
32813               PX(3)=PXP
32814               PY(3)=PYP
32815             ENDIF
32816           ENDIF
32817
32818 C...Junction strings: sum up known four-momentum, coefficients for m2.
32819           DO 470 J=1,4
32820             DHG(J)=0D0
32821             P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
32822      &      PY(3)*P(IN(3)+1,J)
32823             DO 450 IN1=IN(4),IN(1)-4,4
32824               P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
32825   450       CONTINUE
32826             DO 460 IN2=IN(5),IN(2)-4,4
32827               P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
32828   460       CONTINUE
32829   470     CONTINUE
32830           DHM(1)=FOUR(I,I)
32831           DHM(2)=2D0*FOUR(I,IN(1))
32832           DHM(3)=2D0*FOUR(I,IN(2))
32833           DHM(4)=2D0*FOUR(IN(1),IN(2))
32834
32835 C...Junction strings: find coefficients for Gamma expression.
32836           DO 490 IN2=IN(1)+1,IN(2),4
32837             DO 480 IN1=IN(1),IN2-1,4
32838               DHC=2D0*FOUR(IN1,IN2)
32839               DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
32840               IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
32841               IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
32842               IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
32843   480       CONTINUE
32844   490     CONTINUE
32845
32846 C...Junction strings: solve (m2, Gamma) equation system for energies.
32847           DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
32848           IF(ABS(DHS1).LT.1D-4) GOTO 320
32849           DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
32850      &    (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
32851           DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
32852           P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
32853      &    ABS(DHS1)-DHS2/DHS1)
32854           IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320
32855           P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
32856      &    (DHM(2)+DHM(4)*P(IN(2)+2,4))
32857
32858 C...Junction strings: step to new region if necessary.
32859           IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
32860             P(IN(2)+2,4)=P(IN(2)+2,3)
32861             P(IN(2)+2,1)=1D0
32862             IN(2)=IN(2)+4
32863             IF(IN(2).GT.N+NR+4*NS) GOTO 320
32864             IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
32865               P(IN(1)+2,4)=P(IN(1)+2,3)
32866               P(IN(1)+2,1)=0D0
32867               IN(1)=IN(1)+4
32868             ENDIF
32869             GOTO 420
32870           ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
32871             P(IN(1)+2,4)=P(IN(1)+2,3)
32872             P(IN(1)+2,1)=0D0
32873             IN(1)=IN(1)+JS
32874             GOTO 890
32875           ENDIF
32876
32877 C...Junction strings: particle four-momentum, remainder, loop back.
32878   500     DO 510 J=1,4
32879             P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
32880      &      P(IN(2)+2,4)*P(IN(2),J)
32881             PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
32882   510     CONTINUE
32883           IF(P(I,4).LT.P(I,5)) GOTO 320
32884           PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
32885      &    TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
32886           IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
32887             KFL(1)=-KFL(3)
32888             PX(1)=-PX(3)
32889             PY(1)=-PY(3)
32890             GAM(1)=GAM(3)
32891             IF(IN(3).NE.IN(6)) THEN
32892               DO 520 J=1,4
32893                 P(IN(6),J)=P(IN(3),J)
32894                 P(IN(6)+1,J)=P(IN(3)+1,J)
32895   520         CONTINUE
32896             ENDIF
32897             DO 530 JQ=1,2
32898               IN(3+JQ)=IN(JQ)
32899               P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
32900               P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
32901   530       CONTINUE
32902             GOTO 380
32903           ENDIF
32904
32905 C...Junction strings: save quantities left after each string.
32906           IF(IABS(KFL(1)).GT.10) GOTO 320
32907           I=I-1
32908           KFJH(IU)=KFL(1)
32909           DO 540 J=1,4
32910             PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
32911   540     CONTINUE
32912   550   CONTINUE
32913
32914 C...Junction strings: put together to new effective string endpoint.
32915         NJS(JT)=I-ISTA
32916         KFJS(JT)=K(K(MJU(JT+2),3),2)
32917         KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
32918         IF(KFJH(1).EQ.KFJH(2)) KFLS=3
32919         IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),
32920      &  IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+
32921      &  KFLS,KFJH(1))
32922         DO 560 J=1,4
32923           PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
32924           PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
32925   560   CONTINUE
32926         PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
32927      &  PJS(JT,3)**2))
32928   570 CONTINUE
32929
32930 C...Open versus closed strings. Choose breakup region for latter.
32931   580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
32932         NS=MJU(2)-MJU(1)
32933         NB=MJU(1)-N
32934       ELSEIF(MJU(1).NE.0) THEN
32935         NS=N+NR-MJU(1)
32936         NB=MJU(1)-N
32937       ELSEIF(MJU(2).NE.0) THEN
32938         NS=MJU(2)-N
32939         NB=1
32940       ELSEIF(IABS(K(N+1,2)).NE.21) THEN
32941         NS=NR-1
32942         NB=1
32943       ELSE
32944         NS=NR+1
32945         W2SUM=0D0
32946         DO 590 IS=1,NR
32947           P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
32948           W2SUM=W2SUM+P(N+NR+IS,1)
32949   590   CONTINUE
32950         W2RAN=PYR(0)*W2SUM
32951         NB=0
32952   600   NB=NB+1
32953         W2SUM=W2SUM-P(N+NR+NB,1)
32954         IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600
32955       ENDIF
32956
32957 C...Find longitudinal string directions (i.e. lightlike four-vectors).
32958       DO 630 IS=1,NS
32959         IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
32960         IS2=N+IS+NB-NR*((IS+NB-1)/NR)
32961         DO 610 J=1,5
32962           DP(1,J)=P(IS1,J)
32963           IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
32964           IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
32965           DP(2,J)=P(IS2,J)
32966           IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
32967           IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
32968   610   CONTINUE
32969         DP(3,5)=DFOUR(1,1)
32970         DP(4,5)=DFOUR(2,2)
32971         DHKC=DFOUR(1,2)
32972         IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
32973           DP(3,5)=DP(1,5)**2
32974           DP(4,5)=DP(2,5)**2
32975           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2)
32976           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2)
32977           DHKC=DFOUR(1,2)
32978         ENDIF
32979         DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
32980         DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
32981         DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
32982         IN1=N+NR+4*IS-3
32983         P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
32984         DO 620 J=1,4
32985           P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
32986           P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
32987   620   CONTINUE
32988   630 CONTINUE
32989
32990 C...Begin initialization: sum up energy, set starting position.
32991       ISAV=I
32992       MSTU91=MSTU(90)
32993   640 NTRY=NTRY+1
32994       IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN
32995         PARU12=4D0*PARU12
32996         PARU13=2D0*PARU13
32997         GOTO 140
32998       ELSEIF(NTRY.GT.100) THEN
32999         CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
33000         IF(MSTU(21).GE.1) RETURN
33001       ENDIF
33002       I=ISAV
33003       MSTU(90)=MSTU91
33004       DO 660 J=1,4
33005         P(N+NRS,J)=0D0
33006         DO 650 IS=1,NR
33007           P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
33008   650   CONTINUE
33009   660 CONTINUE
33010       DO 680 JT=1,2
33011         IRANK(JT)=0
33012         IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
33013         IF(NS.GT.NR) IRANK(JT)=1
33014         IE(JT)=K(N+1+(JT/2)*(NP-1),3)
33015         IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
33016         IN(3*JT+2)=IN(3*JT+1)+1
33017         IN(3*JT+3)=N+NR+4*NS+2*JT-1
33018         DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
33019           P(IN1,1)=2-JT
33020           P(IN1,2)=JT-1
33021           P(IN1,3)=1D0
33022   670   CONTINUE
33023   680 CONTINUE
33024 C.. MOPS variables and switches
33025       NRVMO=0
33026       XBMO=1D0
33027       MSTU(121)=0
33028       MSTU(122)=0
33029
33030 C...Initialize flavour and pT variables for open string.
33031       IF(NS.LT.NR) THEN
33032         PX(1)=0D0
33033         PY(1)=0D0
33034         IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
33035         PX(2)=-PX(1)
33036         PY(2)=-PY(1)
33037         DO 690 JT=1,2
33038           KFL(JT)=K(IE(JT),2)
33039           IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
33040           MSTJ(93)=1
33041           PMQ(JT)=PYMASS(KFL(JT))
33042           GAM(JT)=0D0
33043   690   CONTINUE
33044
33045 C...Closed string: random initial breakup flavour, pT and vertex.
33046       ELSE
33047         KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33048         IBMO=0
33049   700   CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
33050 C.. Closed string: first vertex diq attempt => enforced second
33051 C.. vertex diq
33052         IF(IABS(KFL(1)).GT.10)THEN
33053            IBMO=1
33054            MSTU(121)=0
33055            GOTO 700
33056         ENDIF
33057         IF(IBMO.EQ.1) MSTU(121)=-1
33058         KFL(2)=-KFL(1)
33059         CALL PYPTDI(KFL(1),PX(1),PY(1))
33060         PX(2)=-PX(1)
33061         PY(2)=-PY(1)
33062         PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
33063   710   CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
33064         ZR=PR3/(Z*P(N+NR+1,5)**2)
33065         IF(ZR.GE.1D0) GOTO 710
33066         DO 720 JT=1,2
33067           MSTJ(93)=1
33068           PMQ(JT)=PYMASS(KFL(JT))
33069           GAM(JT)=PR3*(1D0-Z)/Z
33070           IN1=N+NR+3+4*(JT/2)*(NS-1)
33071           P(IN1,JT)=1D0-Z
33072           P(IN1,3-JT)=JT-1
33073           P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
33074           P(IN1+1,JT)=ZR
33075           P(IN1+1,3-JT)=2-JT
33076           P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
33077   720   CONTINUE
33078       ENDIF
33079 C.. MOPS variables
33080       DO 730 JT=1,2
33081          XTMO(JT)=1D0
33082          PM2QMO(JT)=PMQ(JT)**2
33083          IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
33084   730 CONTINUE
33085
33086 C...Find initial transverse directions (i.e. spacelike four-vectors).
33087       DO 770 JT=1,2
33088         IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
33089           IN1=IN(3*JT+1)
33090           IN3=IN(3*JT+3)
33091           DO 740 J=1,4
33092             DP(1,J)=P(IN1,J)
33093             DP(2,J)=P(IN1+1,J)
33094             DP(3,J)=0D0
33095             DP(4,J)=0D0
33096   740     CONTINUE
33097           DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33098           DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33099           DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33100           DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33101           DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33102           IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33103           IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33104           IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33105           IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33106           DHC12=DFOUR(1,2)
33107           DHCX1=DFOUR(3,1)/DHC12
33108           DHCX2=DFOUR(3,2)/DHC12
33109           DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33110           DHCY1=DFOUR(4,1)/DHC12
33111           DHCY2=DFOUR(4,2)/DHC12
33112           DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33113           DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33114           DO 750 J=1,4
33115             DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33116             P(IN3,J)=DP(3,J)
33117             P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33118      &      DHCYX*DP(3,J))
33119   750     CONTINUE
33120         ELSE
33121           DO 760 J=1,4
33122             P(IN3+2,J)=P(IN3,J)
33123             P(IN3+3,J)=P(IN3+1,J)
33124   760     CONTINUE
33125         ENDIF
33126   770 CONTINUE
33127
33128 C...Remove energy used up in junction string fragmentation.
33129       IF(MJU(1)+MJU(2).GT.0) THEN
33130         DO 790 JT=1,2
33131           IF(NJS(JT).EQ.0) GOTO 790
33132           DO 780 J=1,4
33133             P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
33134   780     CONTINUE
33135   790   CONTINUE
33136       ENDIF
33137
33138 C...Produce new particle: side, origin.
33139   800 I=I+1
33140       IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
33141         CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
33142         IF(MSTU(21).GE.1) RETURN
33143       ENDIF
33144 C.. New side priority for popcorn systems
33145       IF(MSTU(121).LE.0)THEN
33146          JT=1.5D0+PYR(0)
33147          IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
33148          IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
33149       ENDIF
33150       JR=3-JT
33151       JS=3-2*JT
33152       IRANK(JT)=IRANK(JT)+1
33153       K(I,1)=1
33154       K(I,3)=IE(JT)
33155       K(I,4)=0
33156       K(I,5)=0
33157
33158 C...Generate flavour, hadron and pT.
33159   810 CONTINUE
33160       CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
33161       IF(K(I,2).EQ.0) GOTO 640
33162       MU90MO=MSTU(90)
33163       IF(MSTU(121).EQ.-1) GOTO 840
33164       IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
33165      &IABS(KFL(3)).GT.10) THEN
33166         IF(PYR(0).GT.PARJ(19)) GOTO 810
33167       ENDIF
33168       P(I,5)=PYMASS(K(I,2))
33169       CALL PYPTDI(KFL(JT),PX(3),PY(3))
33170       PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
33171
33172 C...Final hadrons for small invariant mass.
33173       MSTJ(93)=1
33174       PMQ(3)=PYMASS(KFL(3))
33175       PARJST=PARJ(33)
33176       IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
33177       WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
33178       IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
33179      &WMIN-0.5D0*PARJ(36)*PMQ(3)
33180       WREM2=FOUR(N+NRS,N+NRS)
33181       IF(WREM2.LT.0.10D0) GOTO 640
33182       IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
33183      &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010
33184
33185 C...Choose z, which gives Gamma. Shift z for heavy flavours.
33186       CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
33187       IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
33188      &MSTU(90).LT.8) THEN
33189         MSTU(90)=MSTU(90)+1
33190         MSTU(90+MSTU(90))=I
33191         PARU(90+MSTU(90))=Z
33192       ENDIF
33193       KFL1A=IABS(KFL(1))
33194       KFL2A=IABS(KFL(2))
33195       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33196      &MOD(KFL2A/1000,10)).GE.4) THEN
33197         PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33198         PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
33199         Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
33200         PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33201         IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010
33202       ENDIF
33203       GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
33204
33205 C.. MOPS baryon model modification
33206       XTMO3=(1D0-Z)*XTMO(JT)
33207       IF(IABS(KFL(3)).LE.10) NRVMO=0
33208       IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
33209          GTSTMO=1D0
33210          PTSTMO=1D0
33211          RTSTMO=PYR(0)
33212          IF(IABS(KFL(JT)).LE.10)THEN
33213             XBMO=MIN(XTMO3,1D0-(2D-10))
33214             GBMO=GAM(3)
33215             PMMO=0D0
33216             PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
33217             GTSTMO=1D0-PARF(192)**PGMO
33218          ELSE
33219             IF(IRANK(JT).EQ.1) THEN
33220                GBMO=GAM(JT)
33221                PMMO=0D0
33222                XBMO=1D0
33223             ENDIF
33224             IF(XBMO.LT.1D0-(1D-10))THEN
33225                PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
33226                GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
33227                PGMO=PGNMO
33228             ENDIF
33229             IF(MSTJ(12).GE.5)THEN
33230                PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
33231                PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
33232                PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
33233                PMMO=PMNMO
33234             ENDIF
33235          ENDIF
33236
33237 C.. MOPS Accepting popcorn system hadron.
33238          IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
33239             IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
33240                NRVMO=I-N-NR
33241                IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
33242                   CALL PYERRM(11,
33243      &                 '(PYSTRF:) no more memory left in PYJETS')
33244                   IF(MSTU(21).GE.1) RETURN
33245                ENDIF
33246                IMO=I
33247                KFLMO=KFL(JT)
33248                PMQMO=PMQ(JT)
33249                PXMO=PX(JT)
33250                PYMO=PY(JT)
33251                GAMMO=GAM(JT)
33252                IRMO=IRANK(JT)
33253                XMO=XTMO(JT)
33254                DO 830 J=1,9
33255                   IF(J.LE.5) THEN
33256                      DO 820 LINE=1,I-N-NR
33257                         P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
33258                         K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
33259   820                CONTINUE
33260                   ENDIF
33261                   INMO(J)=IN(J)
33262   830          CONTINUE
33263             ENDIF
33264          ELSE
33265 C..Reject popcorn system, flag=-1 if enforcing new one
33266             MSTU(121)=-1
33267             IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
33268          ENDIF
33269       ENDIF
33270
33271
33272 C..Lift restoring string outside MOPS block
33273  840  IF(MSTU(121).LT.0) THEN
33274          IF(MSTU(121).EQ.-2) MSTU(121)=0
33275          MSTU(90)=MU90MO
33276          NRVMO=0
33277          IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
33278          I=IMO
33279          KFL(JT)=KFLMO
33280          PMQ(JT)=PMQMO
33281          PX(JT)=PXMO
33282          PY(JT)=PYMO
33283          GAM(JT)=GAMMO
33284          IRANK(JT)=IRMO
33285          XTMO(JT)=XMO
33286          DO 860 J=1,9
33287             IF(J.LE.5) THEN
33288                DO 850 LINE=1,I-N-NR
33289                   P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
33290                   K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
33291  850           CONTINUE
33292             ENDIF
33293             IN(J)=INMO(J)
33294  860     CONTINUE
33295          GOTO 810
33296       ENDIF
33297       XTMO(JT)=XTMO3
33298 C.. MOPS end of modification
33299
33300       DO 870 J=1,3
33301         IN(J)=IN(3*JT+J)
33302   870 CONTINUE
33303
33304 C...Stepping within or from 'low' string region easy.
33305       IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
33306      &P(IN(1),5)**2.GE.PR(JT)) THEN
33307         P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
33308         P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
33309         DO 880 J=1,4
33310           P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
33311   880   CONTINUE
33312         GOTO 970
33313       ELSEIF(IN(1)+1.EQ.IN(2)) THEN
33314         P(IN(JR)+2,4)=P(IN(JR)+2,3)
33315         P(IN(JR)+2,JT)=1D0
33316         IN(JR)=IN(JR)+4*JS
33317         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33318         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33319           P(IN(JT)+2,4)=P(IN(JT)+2,3)
33320           P(IN(JT)+2,JT)=0D0
33321           IN(JT)=IN(JT)+4*JS
33322         ENDIF
33323       ENDIF
33324
33325 C...Find new transverse directions (i.e. spacelike string vectors).
33326   890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
33327      &IN(1).GT.IN(2)) GOTO 640
33328       IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
33329         DO 900 J=1,4
33330           DP(1,J)=P(IN(1),J)
33331           DP(2,J)=P(IN(2),J)
33332           DP(3,J)=0D0
33333           DP(4,J)=0D0
33334   900   CONTINUE
33335         DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
33336         DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
33337         DHC12=DFOUR(1,2)
33338         IF(DHC12.LE.1D-2) THEN
33339           P(IN(JT)+2,4)=P(IN(JT)+2,3)
33340           P(IN(JT)+2,JT)=0D0
33341           IN(JT)=IN(JT)+4*JS
33342           GOTO 890
33343         ENDIF
33344         IN(3)=N+NR+4*NS+5
33345         DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
33346         DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
33347         DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
33348         IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
33349         IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
33350         IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
33351         IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
33352         DHCX1=DFOUR(3,1)/DHC12
33353         DHCX2=DFOUR(3,2)/DHC12
33354         DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
33355         DHCY1=DFOUR(4,1)/DHC12
33356         DHCY2=DFOUR(4,2)/DHC12
33357         DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
33358         DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
33359         DO 910 J=1,4
33360           DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
33361           P(IN(3),J)=DP(3,J)
33362           P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
33363      &    DHCYX*DP(3,J))
33364   910   CONTINUE
33365 C...Express pT with respect to new axes, if sensible.
33366         PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
33367      &  FOUR(IN(3*JT+3)+1,IN(3)))
33368         PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
33369      &  FOUR(IN(3*JT+3)+1,IN(3)+1))
33370         IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
33371           PX(3)=PXP
33372           PY(3)=PYP
33373         ENDIF
33374       ENDIF
33375
33376 C...Sum up known four-momentum. Gives coefficients for m2 expression.
33377       DO 940 J=1,4
33378         DHG(J)=0D0
33379         P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
33380      &  PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
33381         DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
33382           P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
33383   920   CONTINUE
33384         DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
33385           P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
33386   930   CONTINUE
33387   940 CONTINUE
33388       DHM(1)=FOUR(I,I)
33389       DHM(2)=2D0*FOUR(I,IN(1))
33390       DHM(3)=2D0*FOUR(I,IN(2))
33391       DHM(4)=2D0*FOUR(IN(1),IN(2))
33392
33393 C...Find coefficients for Gamma expression.
33394       DO 960 IN2=IN(1)+1,IN(2),4
33395         DO 950 IN1=IN(1),IN2-1,4
33396           DHC=2D0*FOUR(IN1,IN2)
33397           DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
33398           IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
33399           IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
33400           IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
33401   950   CONTINUE
33402   960 CONTINUE
33403
33404 C...Solve (m2, Gamma) equation system for energies taken.
33405       DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
33406       IF(ABS(DHS1).LT.1D-4) GOTO 640
33407       DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
33408      &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
33409       DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
33410       P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
33411      &ABS(DHS1)-DHS2/DHS1)
33412       IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640
33413       P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
33414      &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
33415
33416 C...Step to new region if necessary.
33417       IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
33418         P(IN(JR)+2,4)=P(IN(JR)+2,3)
33419         P(IN(JR)+2,JT)=1D0
33420         IN(JR)=IN(JR)+4*JS
33421         IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640
33422         IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
33423           P(IN(JT)+2,4)=P(IN(JT)+2,3)
33424           P(IN(JT)+2,JT)=0D0
33425           IN(JT)=IN(JT)+4*JS
33426         ENDIF
33427         GOTO 890
33428       ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
33429         P(IN(JT)+2,4)=P(IN(JT)+2,3)
33430         P(IN(JT)+2,JT)=0D0
33431         IN(JT)=IN(JT)+4*JS
33432         GOTO 890
33433       ENDIF
33434
33435 C...Four-momentum of particle. Remaining quantities. Loop back.
33436   970 DO 980 J=1,4
33437         P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
33438         P(N+NRS,J)=P(N+NRS,J)-P(I,J)
33439   980 CONTINUE
33440       IF(P(I,4).LT.P(I,5)) GOTO 640
33441       KFL(JT)=-KFL(3)
33442       PMQ(JT)=PMQ(3)
33443       PX(JT)=-PX(3)
33444       PY(JT)=-PY(3)
33445       GAM(JT)=GAM(3)
33446       IF(IN(3).NE.IN(3*JT+3)) THEN
33447         DO 990 J=1,4
33448           P(IN(3*JT+3),J)=P(IN(3),J)
33449           P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
33450   990   CONTINUE
33451       ENDIF
33452       DO 1000 JQ=1,2
33453         IN(3*JT+JQ)=IN(JQ)
33454         P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
33455         P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
33456  1000 CONTINUE
33457       GOTO 800
33458
33459 C...Final hadron: side, flavour, hadron, mass.
33460  1010 I=I+1
33461       K(I,1)=1
33462       K(I,3)=IE(JR)
33463       K(I,4)=0
33464       K(I,5)=0
33465       CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
33466       IF(K(I,2).EQ.0) GOTO 640
33467       P(I,5)=PYMASS(K(I,2))
33468       PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
33469
33470 C...Final two hadrons: find common setup of four-vectors.
33471       JQ=1
33472       IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)*
33473      &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2
33474       DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
33475       DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
33476       DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
33477       IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
33478         PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
33479         PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
33480         PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
33481      &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
33482       ENDIF
33483
33484 C...Solve kinematics for final two hadrons, if possible.
33485       WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2
33486       FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
33487       IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
33488       IF(FD.GE.1D0) GOTO 640
33489       FA=WREM2+PR(JT)-PR(JR)
33490       IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)*
33491      &(PR(1)+PR(2))**2))
33492       IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39)
33493       FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV))
33494       KFL1A=IABS(KFL(1))
33495       KFL2A=IABS(KFL(2))
33496       IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
33497      &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
33498      &4D0*WREM2*PR(JT))),DBLE(JS))
33499       DO 1020 J=1,4
33500         P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
33501      &  P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
33502      &  DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
33503         P(I,J)=P(N+NRS,J)-P(I-1,J)
33504  1020 CONTINUE
33505       IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640
33506
33507 C...Mark jets as fragmented and give daughter pointers.
33508       N=I-NRS+1
33509       DO 1030 I=NSAV+1,NSAV+NP
33510         IM=K(I,3)
33511         K(IM,1)=K(IM,1)+10
33512         IF(MSTU(16).NE.2) THEN
33513           K(IM,4)=NSAV+1
33514           K(IM,5)=NSAV+1
33515         ELSE
33516           K(IM,4)=NSAV+2
33517           K(IM,5)=N
33518         ENDIF
33519  1030 CONTINUE
33520
33521 C...Document string system. Move up particles.
33522       NSAV=NSAV+1
33523       K(NSAV,1)=11
33524       K(NSAV,2)=92
33525       K(NSAV,3)=IP
33526       K(NSAV,4)=NSAV+1
33527       K(NSAV,5)=N
33528       DO 1040 J=1,4
33529         P(NSAV,J)=DPS(J)
33530         V(NSAV,J)=V(IP,J)
33531  1040 CONTINUE
33532       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
33533       V(NSAV,5)=0D0
33534       DO 1060 I=NSAV+1,N
33535         DO 1050 J=1,5
33536           K(I,J)=K(I+NRS-1,J)
33537           P(I,J)=P(I+NRS-1,J)
33538           V(I,J)=0D0
33539  1050   CONTINUE
33540  1060 CONTINUE
33541       MSTU91=MSTU(90)
33542       DO 1070 IZ=MSTU90+1,MSTU91
33543         MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
33544         PARU9T(IZ)=PARU(90+IZ)
33545  1070 CONTINUE
33546       MSTU(90)=MSTU90
33547
33548 C...Order particles in rank along the chain. Update mother pointer.
33549       DO 1090 I=NSAV+1,N
33550         DO 1080 J=1,5
33551           K(I-NSAV+N,J)=K(I,J)
33552           P(I-NSAV+N,J)=P(I,J)
33553  1080   CONTINUE
33554  1090 CONTINUE
33555       I1=NSAV
33556       DO 1120 I=N+1,2*N-NSAV
33557         IF(K(I,3).NE.IE(1)) GOTO 1120
33558         I1=I1+1
33559         DO 1100 J=1,5
33560           K(I1,J)=K(I,J)
33561           P(I1,J)=P(I,J)
33562  1100   CONTINUE
33563         IF(MSTU(16).NE.2) K(I1,3)=NSAV
33564         DO 1110 IZ=MSTU90+1,MSTU91
33565           IF(MSTU9T(IZ).EQ.I) THEN
33566             MSTU(90)=MSTU(90)+1
33567             MSTU(90+MSTU(90))=I1
33568             PARU(90+MSTU(90))=PARU9T(IZ)
33569           ENDIF
33570  1110   CONTINUE
33571  1120 CONTINUE
33572       DO 1150 I=2*N-NSAV,N+1,-1
33573         IF(K(I,3).EQ.IE(1)) GOTO 1150
33574         I1=I1+1
33575         DO 1130 J=1,5
33576           K(I1,J)=K(I,J)
33577           P(I1,J)=P(I,J)
33578  1130   CONTINUE
33579         IF(MSTU(16).NE.2) K(I1,3)=NSAV
33580         DO 1140 IZ=MSTU90+1,MSTU91
33581           IF(MSTU9T(IZ).EQ.I) THEN
33582             MSTU(90)=MSTU(90)+1
33583             MSTU(90+MSTU(90))=I1
33584             PARU(90+MSTU(90))=PARU9T(IZ)
33585           ENDIF
33586  1140   CONTINUE
33587  1150 CONTINUE
33588
33589 C...Boost back particle system. Set production vertices.
33590       IF(MBST.EQ.0) THEN
33591         MSTU(33)=1
33592         CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
33593      &  DPS(3)/DPS(4))
33594       ELSE
33595         DO 1160 I=NSAV+1,N
33596           HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
33597           IF(P(I,3).GT.0D0) THEN
33598             HHPEZ=(P(I,4)+P(I,3))*HHBZ
33599             P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
33600             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33601           ELSE
33602             HHPEZ=(P(I,4)-P(I,3))/HHBZ
33603             P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
33604             P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
33605           ENDIF
33606  1160   CONTINUE
33607       ENDIF
33608       DO 1180 I=NSAV+1,N
33609         DO 1170 J=1,4
33610           V(I,J)=V(IP,J)
33611  1170   CONTINUE
33612  1180 CONTINUE
33613
33614       RETURN
33615       END
33616
33617 C*********************************************************************
33618
33619 *$ CREATE PYINDF.FOR
33620 *COPY PYINDF
33621 C...PYINDF
33622 C...Handles the fragmentation of a jet system (or a single
33623 C...jet) according to independent fragmentation models.
33624
33625       SUBROUTINE PYINDF(IP)
33626
33627 C...Double precision and integer declarations.
33628       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33629       INTEGER PYK,PYCHGE,PYCOMP
33630 C...Commonblocks.
33631       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
33632       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33633       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33634       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
33635 C...Local arrays.
33636       DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
33637      &KFLO(2),PXO(2),PYO(2),WO(2)
33638
33639 C.. MOPS error message
33640       IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
33641      &' are not treated as expected in independent fragmentation')
33642
33643 C...Reset counters. Identify parton system and take copy. Check flavour.
33644       NSAV=N
33645       MSTU90=MSTU(90)
33646       NJET=0
33647       KQSUM=0
33648       DO 100 J=1,5
33649         DPS(J)=0D0
33650   100 CONTINUE
33651       I=IP-1
33652   110 I=I+1
33653       IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
33654         CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
33655         IF(MSTU(21).GE.1) RETURN
33656       ENDIF
33657       IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
33658       KC=PYCOMP(K(I,2))
33659       IF(KC.EQ.0) GOTO 110
33660       KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
33661       IF(KQ.EQ.0) GOTO 110
33662       NJET=NJET+1
33663       IF(KQ.NE.2) KQSUM=KQSUM+KQ
33664       DO 120 J=1,5
33665         K(NSAV+NJET,J)=K(I,J)
33666         P(NSAV+NJET,J)=P(I,J)
33667         DPS(J)=DPS(J)+P(I,J)
33668   120 CONTINUE
33669       K(NSAV+NJET,3)=I
33670       IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
33671      &K(I+1,1).EQ.2)) GOTO 110
33672       IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
33673         CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
33674         IF(MSTU(21).GE.1) RETURN
33675       ENDIF
33676
33677 C...Boost copied system to CM frame. Find CM energy and sum flavours.
33678       IF(NJET.NE.1) THEN
33679         MSTU(33)=1
33680         CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
33681      &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
33682       ENDIF
33683       PECM=0D0
33684       DO 130 J=1,3
33685         NFI(J)=0
33686   130 CONTINUE
33687       DO 140 I=NSAV+1,NSAV+NJET
33688         PECM=PECM+P(I,4)
33689         KFA=IABS(K(I,2))
33690         IF(KFA.LE.3) THEN
33691           NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
33692         ELSEIF(KFA.GT.1000) THEN
33693           KFLA=MOD(KFA/1000,10)
33694           KFLB=MOD(KFA/100,10)
33695           IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
33696           IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
33697         ENDIF
33698   140 CONTINUE
33699
33700 C...Loop over attempts made. Reset counters.
33701       NTRY=0
33702   150 NTRY=NTRY+1
33703       IF(NTRY.GT.200) THEN
33704         CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
33705         IF(MSTU(21).GE.1) RETURN
33706       ENDIF
33707       N=NSAV+NJET
33708       MSTU(90)=MSTU90
33709       DO 160 J=1,3
33710         NFL(J)=NFI(J)
33711         IFET(J)=0
33712         KFLF(J)=0
33713   160 CONTINUE
33714
33715 C...Loop over jets to be fragmented.
33716       DO 230 IP1=NSAV+1,NSAV+NJET
33717         MSTJ(91)=0
33718         NSAV1=N
33719         MSTU91=MSTU(90)
33720
33721 C...Initial flavour and momentum values. Jet along +z axis.
33722         KFLH=IABS(K(IP1,2))
33723         IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
33724         KFLO(2)=0
33725         WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
33726
33727 C...Initial values for quark or diquark jet.
33728   170   IF(IABS(K(IP1,2)).NE.21) THEN
33729           NSTR=1
33730           KFLO(1)=K(IP1,2)
33731           CALL PYPTDI(0,PXO(1),PYO(1))
33732           WO(1)=WF
33733
33734 C...Initial values for gluon treated like random quark jet.
33735         ELSEIF(MSTJ(2).LE.2) THEN
33736           NSTR=1
33737           IF(MSTJ(2).EQ.2) MSTJ(91)=1
33738           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33739           CALL PYPTDI(0,PXO(1),PYO(1))
33740           WO(1)=WF
33741
33742 C...Initial values for gluon treated like quark-antiquark jet pair,
33743 C...sharing energy according to Altarelli-Parisi splitting function.
33744         ELSE
33745           NSTR=2
33746           IF(MSTJ(2).EQ.4) MSTJ(91)=1
33747           KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
33748           KFLO(2)=-KFLO(1)
33749           CALL PYPTDI(0,PXO(1),PYO(1))
33750           PXO(2)=-PXO(1)
33751           PYO(2)=-PYO(1)
33752           WO(1)=WF*PYR(0)**(1D0/3D0)
33753           WO(2)=WF-WO(1)
33754         ENDIF
33755
33756 C...Initial values for rank, flavour, pT and W+.
33757         DO 220 ISTR=1,NSTR
33758   180     I=N
33759           MSTU(90)=MSTU91
33760           IRANK=0
33761           KFL1=KFLO(ISTR)
33762           PX1=PXO(ISTR)
33763           PY1=PYO(ISTR)
33764           W=WO(ISTR)
33765
33766 C...New hadron. Generate flavour and hadron species.
33767   190     I=I+1
33768           IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
33769             CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
33770             IF(MSTU(21).GE.1) RETURN
33771           ENDIF
33772           IRANK=IRANK+1
33773           K(I,1)=1
33774           K(I,3)=IP1
33775           K(I,4)=0
33776           K(I,5)=0
33777   200     CALL PYKFDI(KFL1,0,KFL2,K(I,2))
33778           IF(K(I,2).EQ.0) GOTO 180
33779           IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
33780             IF(PYR(0).GT.PARJ(19)) GOTO 200
33781           ENDIF
33782
33783 C...Find hadron mass. Generate four-momentum.
33784           P(I,5)=PYMASS(K(I,2))
33785           CALL PYPTDI(KFL1,PX2,PY2)
33786           P(I,1)=PX1+PX2
33787           P(I,2)=PY1+PY2
33788           PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
33789           CALL PYZDIS(KFL1,KFL2,PR,Z)
33790           MZSAV=0
33791           IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
33792             MZSAV=1
33793             MSTU(90)=MSTU(90)+1
33794             MSTU(90+MSTU(90))=I
33795             PARU(90+MSTU(90))=Z
33796           ENDIF
33797           P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
33798           P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
33799           IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
33800      &    P(I,3).LE.0.001D0) THEN
33801             IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
33802             P(I,3)=0.0001D0
33803             P(I,4)=SQRT(PR)
33804             Z=P(I,4)/W
33805           ENDIF
33806
33807 C...Remaining flavour and momentum.
33808           KFL1=-KFL2
33809           PX1=-PX2
33810           PY1=-PY2
33811           W=(1D0-Z)*W
33812           DO 210 J=1,5
33813             V(I,J)=0D0
33814   210     CONTINUE
33815
33816 C...Check if pL acceptable. Go back for new hadron if enough energy.
33817           IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
33818             I=I-1
33819             IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
33820           ENDIF
33821           IF(W.GT.PARJ(31)) GOTO 190
33822           N=I
33823   220   CONTINUE
33824         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
33825         IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
33826
33827 C...Rotate jet to new direction.
33828         THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
33829         PHI=PYANGL(P(IP1,1),P(IP1,2))
33830         MSTU(33)=1
33831         CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
33832         K(K(IP1,3),4)=NSAV1+1
33833         K(K(IP1,3),5)=N
33834
33835 C...End of jet generation loop. Skip conservation in some cases.
33836   230 CONTINUE
33837       IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
33838       IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
33839
33840 C...Subtract off produced hadron flavours, finished if zero.
33841       DO 240 I=NSAV+NJET+1,N
33842         KFA=IABS(K(I,2))
33843         KFLA=MOD(KFA/1000,10)
33844         KFLB=MOD(KFA/100,10)
33845         KFLC=MOD(KFA/10,10)
33846         IF(KFLA.EQ.0) THEN
33847           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
33848           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
33849         ELSE
33850           IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
33851           IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
33852           IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
33853         ENDIF
33854   240 CONTINUE
33855       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33856      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33857       IF(NREQ.EQ.0) GOTO 320
33858
33859 C...Take away flavour of low-momentum particles until enough freedom.
33860       NREM=0
33861   250 IREM=0
33862       P2MIN=PECM**2
33863       DO 260 I=NSAV+NJET+1,N
33864         P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
33865         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
33866         IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
33867   260 CONTINUE
33868       IF(IREM.EQ.0) GOTO 150
33869       K(IREM,1)=7
33870       KFA=IABS(K(IREM,2))
33871       KFLA=MOD(KFA/1000,10)
33872       KFLB=MOD(KFA/100,10)
33873       KFLC=MOD(KFA/10,10)
33874       IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
33875       IF(K(IREM,1).EQ.8) GOTO 250
33876       IF(KFLA.EQ.0) THEN
33877         ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
33878         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
33879         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
33880       ELSE
33881         IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
33882         IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
33883         IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
33884       ENDIF
33885       NREM=NREM+1
33886       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33887      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33888       IF(NREQ.GT.NREM) GOTO 250
33889       DO 270 I=NSAV+NJET+1,N
33890         IF(K(I,1).EQ.8) K(I,1)=1
33891   270 CONTINUE
33892
33893 C...Find combination of existing and new flavours for hadron.
33894   280 NFET=2
33895       IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
33896       IF(NREQ.LT.NREM) NFET=1
33897       IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
33898       DO 290 J=1,NFET
33899         IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
33900         KFLF(J)=ISIGN(1,NFL(1))
33901         IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
33902         IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
33903   290 CONTINUE
33904       IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
33905      &GOTO 280
33906       IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
33907      &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
33908      &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
33909       IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
33910       IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
33911       IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
33912       IF(NFET.LE.2) KFLF(3)=0
33913       IF(KFLF(3).NE.0) THEN
33914         KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
33915      &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
33916         IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
33917      &  KFLFC=KFLFC+ISIGN(2,KFLFC)
33918       ELSE
33919         KFLFC=KFLF(1)
33920       ENDIF
33921       CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
33922       IF(KF.EQ.0) GOTO 280
33923       DO 300 J=1,MAX(2,NFET)
33924         NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
33925   300 CONTINUE
33926
33927 C...Store hadron at random among free positions.
33928       NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
33929       DO 310 I=NSAV+NJET+1,N
33930         IF(K(I,1).EQ.7) NPOS=NPOS-1
33931         IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
33932         K(I,1)=1
33933         K(I,2)=KF
33934         P(I,5)=PYMASS(K(I,2))
33935         P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33936   310 CONTINUE
33937       NREM=NREM-1
33938       NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
33939      &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
33940       IF(NREM.GT.0) GOTO 280
33941
33942 C...Compensate for missing momentum in global scheme (3 options).
33943   320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
33944         DO 340 J=1,3
33945           PSI(J)=0D0
33946           DO 330 I=NSAV+NJET+1,N
33947             PSI(J)=PSI(J)+P(I,J)
33948   330     CONTINUE
33949   340   CONTINUE
33950         PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
33951         PWS=0D0
33952         DO 350 I=NSAV+NJET+1,N
33953           IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
33954           IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33955      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33956           IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
33957   350   CONTINUE
33958         DO 370 I=NSAV+NJET+1,N
33959           IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
33960           IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
33961      &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
33962           IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
33963           DO 360 J=1,3
33964             P(I,J)=P(I,J)-PSI(J)*PW/PWS
33965   360     CONTINUE
33966           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
33967   370   CONTINUE
33968
33969 C...Compensate for missing momentum withing each jet separately.
33970       ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
33971         DO 390 I=N+1,N+NJET
33972           K(I,1)=0
33973           DO 380 J=1,5
33974             P(I,J)=0D0
33975   380     CONTINUE
33976   390   CONTINUE
33977         DO 410 I=NSAV+NJET+1,N
33978           IR1=K(I,3)
33979           IR2=N+IR1-NSAV
33980           K(IR2,1)=K(IR2,1)+1
33981           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33982      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33983           DO 400 J=1,3
33984             P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
33985   400     CONTINUE
33986           P(IR2,4)=P(IR2,4)+P(I,4)
33987           P(IR2,5)=P(IR2,5)+PLS
33988   410   CONTINUE
33989         PSS=0D0
33990         DO 420 I=N+1,N+NJET
33991           IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
33992   420   CONTINUE
33993         DO 440 I=NSAV+NJET+1,N
33994           IR1=K(I,3)
33995           IR2=N+IR1-NSAV
33996           PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
33997      &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
33998           DO 430 J=1,3
33999             P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
34000      &      PLS*P(IR1,J)
34001   430     CONTINUE
34002           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34003   440   CONTINUE
34004       ENDIF
34005
34006 C...Scale momenta for energy conservation.
34007       IF(MOD(MSTJ(3),5).NE.0) THEN
34008         PMS=0D0
34009         PES=0D0
34010         PQS=0D0
34011         DO 450 I=NSAV+NJET+1,N
34012           PMS=PMS+P(I,5)
34013           PES=PES+P(I,4)
34014           PQS=PQS+P(I,5)**2/P(I,4)
34015   450   CONTINUE
34016         IF(PMS.GE.PECM) GOTO 150
34017         NECO=0
34018   460   NECO=NECO+1
34019         PFAC=(PECM-PQS)/(PES-PQS)
34020         PES=0D0
34021         PQS=0D0
34022         DO 480 I=NSAV+NJET+1,N
34023           DO 470 J=1,3
34024             P(I,J)=PFAC*P(I,J)
34025   470     CONTINUE
34026           P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
34027           PES=PES+P(I,4)
34028           PQS=PQS+P(I,5)**2/P(I,4)
34029   480   CONTINUE
34030         IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
34031       ENDIF
34032
34033 C...Origin of produced particles and parton daughter pointers.
34034   490 DO 500 I=NSAV+NJET+1,N
34035         IF(MSTU(16).NE.2) K(I,3)=NSAV+1
34036         IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
34037   500 CONTINUE
34038       DO 510 I=NSAV+1,NSAV+NJET
34039         I1=K(I,3)
34040         K(I1,1)=K(I1,1)+10
34041         IF(MSTU(16).NE.2) THEN
34042           K(I1,4)=NSAV+1
34043           K(I1,5)=NSAV+1
34044         ELSE
34045           K(I1,4)=K(I1,4)-NJET+1
34046           K(I1,5)=K(I1,5)-NJET+1
34047           IF(K(I1,5).LT.K(I1,4)) THEN
34048             K(I1,4)=0
34049             K(I1,5)=0
34050           ENDIF
34051         ENDIF
34052   510 CONTINUE
34053
34054 C...Document independent fragmentation system. Remove copy of jets.
34055       NSAV=NSAV+1
34056       K(NSAV,1)=11
34057       K(NSAV,2)=93
34058       K(NSAV,3)=IP
34059       K(NSAV,4)=NSAV+1
34060       K(NSAV,5)=N-NJET+1
34061       DO 520 J=1,4
34062         P(NSAV,J)=DPS(J)
34063         V(NSAV,J)=V(IP,J)
34064   520 CONTINUE
34065       P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
34066       V(NSAV,5)=0D0
34067       DO 540 I=NSAV+NJET,N
34068         DO 530 J=1,5
34069           K(I-NJET+1,J)=K(I,J)
34070           P(I-NJET+1,J)=P(I,J)
34071           V(I-NJET+1,J)=V(I,J)
34072   530   CONTINUE
34073   540 CONTINUE
34074       N=N-NJET+1
34075       DO 550 IZ=MSTU90+1,MSTU(90)
34076         MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
34077   550 CONTINUE
34078
34079 C...Boost back particle system. Set production vertices.
34080       IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
34081      &DPS(2)/DPS(4),DPS(3)/DPS(4))
34082       DO 570 I=NSAV+1,N
34083         DO 560 J=1,4
34084           V(I,J)=V(IP,J)
34085   560   CONTINUE
34086   570 CONTINUE
34087
34088       RETURN
34089       END
34090
34091 C*********************************************************************
34092
34093 *$ CREATE PYDECY.FOR
34094 *COPY PYDECY
34095 C...PYDECY
34096 C...Handles the decay of unstable particles.
34097
34098       SUBROUTINE PYDECY(IP)
34099
34100 C...Double precision and integer declarations.
34101       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34102       INTEGER PYK,PYCHGE,PYCOMP
34103 C...Commonblocks.
34104       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
34105       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34106       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34107       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
34108       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
34109 C...Local arrays.
34110       DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
34111      &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
34112       CHARACTER CIDC*4
34113       DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
34114
34115 C...Functions: momentum in two-particle decays and four-product.
34116       PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
34117       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)
34118
34119 C...Initial values.
34120       NTRY=0
34121       NSAV=N
34122       KFA=IABS(K(IP,2))
34123       KFS=ISIGN(1,K(IP,2))
34124       KC=PYCOMP(KFA)
34125       MSTJ(92)=0
34126
34127 C...Choose lifetime and determine decay vertex.
34128       IF(K(IP,1).EQ.5) THEN
34129         V(IP,5)=0D0
34130       ELSEIF(K(IP,1).NE.4) THEN
34131         V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
34132       ENDIF
34133       DO 100 J=1,4
34134         VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
34135   100 CONTINUE
34136
34137 C...Determine whether decay allowed or not.
34138       MOUT=0
34139       IF(MSTJ(22).EQ.2) THEN
34140         IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
34141       ELSEIF(MSTJ(22).EQ.3) THEN
34142         IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
34143       ELSEIF(MSTJ(22).EQ.4) THEN
34144         IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
34145         IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
34146       ENDIF
34147       IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
34148         K(IP,1)=4
34149         RETURN
34150       ENDIF
34151
34152 C...Interface to external tau decay library (for tau polarization).
34153       IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
34154
34155 C...Starting values for pointers and momenta.
34156         ITAU=IP
34157         DO 110 J=1,4
34158           PTAU(J)=P(ITAU,J)
34159           PCMTAU(J)=P(ITAU,J)
34160   110   CONTINUE
34161
34162 C...Iterate to find position and code of mother of tau.
34163         IMTAU=ITAU
34164   120   IMTAU=K(IMTAU,3)
34165
34166         IF(IMTAU.EQ.0) THEN
34167 C...If no known origin then impossible to do anything further.
34168           KFORIG=0
34169           IORIG=0
34170
34171         ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
34172 C...If tau -> tau + gamma then add gamma energy and loop.
34173           IF(K(K(IMTAU,4),2).EQ.22) THEN
34174             DO 130 J=1,4
34175               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
34176   130       CONTINUE
34177           ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
34178             DO 140 J=1,4
34179               PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
34180   140       CONTINUE
34181           ENDIF
34182           GOTO 120
34183
34184         ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
34185 C...If coming from weak decay of hadron then W is not stored in record,
34186 C...but can be reconstructed by adding neutrino momentum.
34187           KFORIG=-ISIGN(24,K(ITAU,2))
34188           IORIG=0
34189           DO 160 II=K(IMTAU,4),K(IMTAU,5)
34190             IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
34191               DO 150 J=1,4
34192                 PCMTAU(J)=PCMTAU(J)+P(II,J)
34193   150         CONTINUE
34194             ENDIF
34195   160     CONTINUE
34196
34197         ELSE
34198 C...If coming from resonance decay then find latest copy of this
34199 C...resonance (may not completely agree).
34200           KFORIG=K(IMTAU,2)
34201           IORIG=IMTAU
34202           DO 170 II=IMTAU+1,IP-1
34203             IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
34204      &      ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
34205   170     CONTINUE
34206           DO 180 J=1,4
34207             PCMTAU(J)=P(IORIG,J)
34208   180     CONTINUE
34209         ENDIF
34210
34211 C...Boost tau to rest frame of production process (where known)
34212 C...and rotate it to sit along +z axis.
34213         DO 190 J=1,3
34214           DBETAU(J)=PCMTAU(J)/PCMTAU(4)
34215   190   CONTINUE
34216         IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
34217      &  -DBETAU(2),-DBETAU(3))
34218         PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
34219         CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
34220         THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
34221         CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
34222
34223 C...Call tau decay routine (if meaningful) and fill extra info.
34224         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34225           CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
34226           DO 200 II=NSAV+1,NSAV+NDECAY
34227             K(II,1)=1
34228             K(II,3)=IP
34229             K(II,4)=0
34230             K(II,5)=0
34231   200     CONTINUE
34232           N=NSAV+NDECAY
34233         ENDIF
34234
34235 C...Boost back decay tau and decay products.
34236         DO 210 J=1,4
34237           P(ITAU,J)=PTAU(J)
34238   210   CONTINUE
34239         IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
34240           CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
34241           IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
34242      &    DBETAU(2),DBETAU(3))
34243
34244 C...Skip past ordinary tau decay treatment.
34245           MMAT=0
34246           MBST=0
34247           ND=0
34248           GOTO 630
34249         ENDIF
34250       ENDIF
34251
34252 C...B-Bbar mixing: flip sign of meson appropriately.
34253       MMIX=0
34254       IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
34255         XBBMIX=PARJ(76)
34256         IF(KFA.EQ.531) XBBMIX=PARJ(77)
34257         IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
34258         IF(MMIX.EQ.1) KFS=-KFS
34259       ENDIF
34260
34261 C...Check existence of decay channels. Particle/antiparticle rules.
34262       KCA=KC
34263       IF(MDCY(KC,2).GT.0) THEN
34264         MDMDCY=MDME(MDCY(KC,2),2)
34265         IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
34266       ENDIF
34267       IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
34268         CALL PYERRM(9,'(PYDECY:) no decay channel defined')
34269         RETURN
34270       ENDIF
34271       IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
34272       IF(KCHG(KC,3).EQ.0) THEN
34273         KFSP=1
34274         KFSN=0
34275         IF(PYR(0).GT.0.5D0) KFS=-KFS
34276       ELSEIF(KFS.GT.0) THEN
34277         KFSP=1
34278         KFSN=0
34279       ELSE
34280         KFSP=0
34281         KFSN=1
34282       ENDIF
34283
34284 C...Sum branching ratios of allowed decay channels.
34285   220 NOPE=0
34286       BRSU=0D0
34287       DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
34288         IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34289      &  KFSN*MDME(IDL,1).NE.3) GOTO 230
34290         IF(MDME(IDL,2).GT.100) GOTO 230
34291         NOPE=NOPE+1
34292         BRSU=BRSU+BRAT(IDL)
34293   230 CONTINUE
34294       IF(NOPE.EQ.0) THEN
34295         CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
34296         RETURN
34297       ENDIF
34298
34299 C...Select decay channel among allowed ones.
34300   240 RBR=BRSU*PYR(0)
34301       IDL=MDCY(KCA,2)-1
34302   250 IDL=IDL+1
34303       IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
34304      &KFSN*MDME(IDL,1).NE.3) THEN
34305         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34306       ELSEIF(MDME(IDL,2).GT.100) THEN
34307         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
34308       ELSE
34309         IDC=IDL
34310         RBR=RBR-BRAT(IDL)
34311         IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
34312       ENDIF
34313
34314 C...Start readout of decay channel: matrix element, reset counters.
34315       MMAT=MDME(IDC,2)
34316   260 NTRY=NTRY+1
34317       IF(MOD(NTRY,200).EQ.0) THEN
34318         WRITE(CIDC,'(I4)') IDC
34319         CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
34320      &  CIDC)
34321         GOTO 240
34322       ENDIF
34323       IF(NTRY.GT.1000) THEN
34324         CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34325         IF(MSTU(21).GE.1) RETURN
34326       ENDIF
34327       I=N
34328       NP=0
34329       NQ=0
34330       MBST=0
34331       IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
34332       DO 270 J=1,4
34333         PV(1,J)=0D0
34334         IF(MBST.EQ.0) PV(1,J)=P(IP,J)
34335   270 CONTINUE
34336       IF(MBST.EQ.1) PV(1,4)=P(IP,5)
34337       PV(1,5)=P(IP,5)
34338       PS=0D0
34339       PSQ=0D0
34340       MREM=0
34341       MHADDY=0
34342       IF(KFA.GT.80) MHADDY=1
34343 C.. Random flavour and popcorn system memory.
34344       IRNDMO=0
34345       JTMO=0
34346       MSTU(121)=0
34347       MSTU(125)=10
34348
34349 C...Read out decay products. Convert to standard flavour code.
34350       JTMAX=5
34351       IF(MDME(IDC+1,2).EQ.101) JTMAX=10
34352       DO 280 JT=1,JTMAX
34353         IF(JT.LE.5) KP=KFDP(IDC,JT)
34354         IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
34355         IF(KP.EQ.0) GOTO 280
34356         KPA=IABS(KP)
34357         KCP=PYCOMP(KPA)
34358         IF(KPA.GT.80) MHADDY=1
34359         IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
34360           KFP=KP
34361         ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
34362           KFP=KFS*KP
34363         ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
34364           KFP=-KFS*MOD(KFA/10,10)
34365         ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
34366           KFP=KFS*(100*MOD(KFA/10,100)+3)
34367         ELSEIF(KPA.EQ.81) THEN
34368           KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
34369         ELSEIF(KP.EQ.82) THEN
34370           CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
34371           IF(KFP.EQ.0) GOTO 260
34372           KFP=-KFP
34373           IRNDMO=1
34374           MSTJ(93)=1
34375           IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
34376         ELSEIF(KP.EQ.-82) THEN
34377           KFP=MSTU(124)
34378         ENDIF
34379         IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
34380
34381 C...Add decay product to event record or to quark flavour list.
34382         KFPA=IABS(KFP)
34383         KQP=KCHG(KCP,2)
34384         IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
34385           NQ=NQ+1
34386           KFLO(NQ)=KFP
34387 C...set rndmflav popcorn system pointer
34388           IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
34389           MSTJ(93)=2
34390           PSQ=PSQ+PYMASS(KFLO(NQ))
34391         ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
34392      &    MOD(NQ,2).EQ.1) THEN
34393           NQ=NQ-1
34394           PS=PS-P(I,5)
34395           K(I,1)=1
34396           KFI=K(I,2)
34397           CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
34398           IF(K(I,2).EQ.0) GOTO 260
34399           MSTJ(93)=1
34400           P(I,5)=PYMASS(K(I,2))
34401           PS=PS+P(I,5)
34402         ELSE
34403           I=I+1
34404           NP=NP+1
34405           IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
34406           IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
34407           K(I,1)=1+MOD(NQ,2)
34408           IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
34409           IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
34410           K(I,2)=KFP
34411           K(I,3)=IP
34412           K(I,4)=0
34413           K(I,5)=0
34414           P(I,5)=PYMASS(KFP)
34415           PS=PS+P(I,5)
34416         ENDIF
34417   280 CONTINUE
34418
34419 C...Check masses for resonance decays.
34420       IF(MHADDY.EQ.0) THEN
34421         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
34422       ENDIF
34423
34424 C...Choose decay multiplicity in phase space model.
34425   290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
34426         PSP=PS
34427         CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
34428         IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
34429   300   NTRY=NTRY+1
34430 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
34431         IF(IRNDMO.EQ.0) THEN
34432            MSTU(121)=0
34433            JTMO=0
34434         ELSEIF(IRNDMO.EQ.1) THEN
34435            IRNDMO=2
34436         ELSE
34437            GOTO 260
34438         ENDIF
34439         IF(NTRY.GT.1000) THEN
34440           CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
34441           IF(MSTU(21).GE.1) RETURN
34442         ENDIF
34443         IF(MMAT.LE.20) THEN
34444           GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
34445      &    SIN(PARU(2)*PYR(0))
34446           ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
34447           IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
34448           IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
34449           IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
34450           IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
34451         ELSE
34452           ND=MMAT-20
34453         ENDIF
34454 C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
34455         MSTU(125)=ND-NQ/2
34456         IF(MSTU(121).GT.MSTU(125)) GOTO 300
34457
34458 C...Form hadrons from flavour content.
34459         DO 310 JT=1,4
34460           KFL1(JT)=KFLO(JT)
34461   310   CONTINUE
34462         IF(ND.EQ.NP+NQ/2) GOTO 330
34463         DO 320 I=N+NP+1,N+ND-NQ/2
34464 C.. Stick to started popcorn system, else pick side at random
34465           JT=JTMO
34466           IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
34467           CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
34468           IF(K(I,2).EQ.0) GOTO 300
34469           MSTU(125)=MSTU(125)-1
34470           JTMO=0
34471           IF(MSTU(121).GT.0) JTMO=JT
34472           KFL1(JT)=-KFL2
34473   320   CONTINUE
34474   330   JT=2
34475         JT2=3
34476         JT3=4
34477         IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
34478         IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
34479      &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
34480         IF(JT.EQ.3) JT2=2
34481         IF(JT.EQ.4) JT3=2
34482         CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
34483         IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
34484         IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
34485         IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
34486
34487 C...Check that sum of decay product masses not too large.
34488         PS=PSP
34489         DO 340 I=N+NP+1,N+ND
34490           K(I,1)=1
34491           K(I,3)=IP
34492           K(I,4)=0
34493           K(I,5)=0
34494           P(I,5)=PYMASS(K(I,2))
34495           PS=PS+P(I,5)
34496   340   CONTINUE
34497         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
34498
34499 C...Rescale energy to subtract off spectator quark mass.
34500       ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
34501      &  .AND.NP.GE.3) THEN
34502         PS=PS-P(N+NP,5)
34503         PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
34504         DO 350 J=1,5
34505           P(N+NP,J)=PQT*PV(1,J)
34506           PV(1,J)=(1D0-PQT)*PV(1,J)
34507   350   CONTINUE
34508         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34509         ND=NP-1
34510         MREM=1
34511
34512 C...Fully specified final state: check mass broadening effects.
34513       ELSE
34514         IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
34515         ND=NP
34516       ENDIF
34517
34518 C...Determine position of grandmother, number of sisters.
34519       NM=0
34520       KFAS=0
34521       MSGN=0
34522       IF(MMAT.EQ.3) THEN
34523         IM=K(IP,3)
34524         IF(IM.LT.0.OR.IM.GE.IP) IM=0
34525         IF(IM.NE.0) KFAM=IABS(K(IM,2))
34526         IF(IM.NE.0) THEN
34527           DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
34528             IF(K(IL,3).EQ.IM) NM=NM+1
34529             IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
34530   360     CONTINUE
34531           IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
34532      &    MOD(KFAM/1000,10).NE.0) NM=0
34533           IF(NM.EQ.2) THEN
34534             KFAS=IABS(K(ISIS,2))
34535             IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
34536      &      MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
34537           ENDIF
34538         ENDIF
34539       ENDIF
34540
34541 C...Kinematics of one-particle decays.
34542       IF(ND.EQ.1) THEN
34543         DO 370 J=1,4
34544           P(N+1,J)=P(IP,J)
34545   370   CONTINUE
34546         GOTO 630
34547       ENDIF
34548
34549 C...Calculate maximum weight ND-particle decay.
34550       PV(ND,5)=P(N+ND,5)
34551       IF(ND.GE.3) THEN
34552         WTMAX=1D0/WTCOR(ND-2)
34553         PMAX=PV(1,5)-PS+P(N+ND,5)
34554         PMIN=0D0
34555         DO 380 IL=ND-1,1,-1
34556           PMAX=PMAX+P(N+IL,5)
34557           PMIN=PMIN+P(N+IL+1,5)
34558           WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
34559   380   CONTINUE
34560       ENDIF
34561
34562 C...Find virtual gamma mass in Dalitz decay.
34563   390 IF(ND.EQ.2) THEN
34564       ELSEIF(MMAT.EQ.2) THEN
34565         PMES=4D0*PMAS(11,1)**2
34566         PMRHO2=PMAS(131,1)**2
34567         PGRHO2=PMAS(131,2)**2
34568   400   PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
34569         WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
34570      &  (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
34571      &  ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
34572         IF(WT.LT.PYR(0)) GOTO 400
34573         PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
34574
34575 C...M-generator gives weight. If rejected, try again.
34576       ELSE
34577   410   RORD(1)=1D0
34578         DO 440 IL1=2,ND-1
34579           RSAV=PYR(0)
34580           DO 420 IL2=IL1-1,1,-1
34581             IF(RSAV.LE.RORD(IL2)) GOTO 430
34582             RORD(IL2+1)=RORD(IL2)
34583   420     CONTINUE
34584   430     RORD(IL2+1)=RSAV
34585   440   CONTINUE
34586         RORD(ND)=0D0
34587         WT=1D0
34588         DO 450 IL=ND-1,1,-1
34589           PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
34590      &    (PV(1,5)-PS)
34591           WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34592   450   CONTINUE
34593         IF(WT.LT.PYR(0)*WTMAX) GOTO 410
34594       ENDIF
34595
34596 C...Perform two-particle decays in respective CM frame.
34597   460 DO 480 IL=1,ND-1
34598         PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
34599         UE(3)=2D0*PYR(0)-1D0
34600         PHI=PARU(2)*PYR(0)
34601         UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
34602         UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
34603         DO 470 J=1,3
34604           P(N+IL,J)=PA*UE(J)
34605           PV(IL+1,J)=-PA*UE(J)
34606   470   CONTINUE
34607         P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
34608         PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
34609   480 CONTINUE
34610
34611 C...Lorentz transform decay products to lab frame.
34612       DO 490 J=1,4
34613         P(N+ND,J)=PV(ND,J)
34614   490 CONTINUE
34615       DO 530 IL=ND-1,1,-1
34616         DO 500 J=1,3
34617           BE(J)=PV(IL,J)/PV(IL,4)
34618   500   CONTINUE
34619         GA=PV(IL,4)/PV(IL,5)
34620         DO 520 I=N+IL,N+ND
34621           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34622           DO 510 J=1,3
34623             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34624   510     CONTINUE
34625           P(I,4)=GA*(P(I,4)+BEP)
34626   520   CONTINUE
34627   530 CONTINUE
34628
34629 C...Check that no infinite loop in matrix element weight.
34630       NTRY=NTRY+1
34631       IF(NTRY.GT.800) GOTO 560
34632
34633 C...Matrix elements for omega and phi decays.
34634       IF(MMAT.EQ.1) THEN
34635         WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
34636      &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
34637      &  +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
34638         IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
34639
34640 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
34641       ELSEIF(MMAT.EQ.2) THEN
34642         FOUR12=FOUR(N+1,N+2)
34643         FOUR13=FOUR(N+1,N+3)
34644         WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
34645      &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
34646         IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
34647
34648 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
34649 C...V vector), of form cos**2(theta02) in V1 rest frame, and for
34650 C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
34651       ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
34652         FOUR10=FOUR(IP,IM)
34653         FOUR12=FOUR(IP,N+1)
34654         FOUR02=FOUR(IM,N+1)
34655         PMS1=P(IP,5)**2
34656         PMS0=P(IM,5)**2
34657         PMS2=P(N+1,5)**2
34658         IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
34659         IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
34660      &  PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
34661         HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
34662         HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
34663         IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
34664
34665 C...Matrix element for "onium" -> g + g + g or gamma + g + g.
34666       ELSEIF(MMAT.EQ.4) THEN
34667         HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34668         HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
34669         HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
34670         WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
34671      &  ((1D0-HX3)/(HX1*HX2))**2
34672         IF(WT.LT.2D0*PYR(0)) GOTO 390
34673         IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
34674      &  GOTO 390
34675
34676 C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
34677       ELSEIF(MMAT.EQ.41) THEN
34678         HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
34679         HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
34680         IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
34681
34682 C...Matrix elements for weak decays (only semileptonic for c and b)
34683       ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34684      &  .AND.ND.EQ.3) THEN
34685         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
34686         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
34687         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34688       ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
34689         DO 550 J=1,4
34690           P(N+NP+1,J)=0D0
34691           DO 540 IS=N+3,N+NP
34692             P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
34693   540     CONTINUE
34694   550   CONTINUE
34695         IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
34696         IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
34697         IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
34698       ENDIF
34699
34700 C...Scale back energy and reattach spectator.
34701   560 IF(MREM.EQ.1) THEN
34702         DO 570 J=1,5
34703           PV(1,J)=PV(1,J)/(1D0-PQT)
34704   570   CONTINUE
34705         ND=ND+1
34706         MREM=0
34707       ENDIF
34708
34709 C...Low invariant mass for system with spectator quark gives particle,
34710 C...not two jets. Readjust momenta accordingly.
34711       IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
34712         MSTJ(93)=1
34713         PM2=PYMASS(K(N+2,2))
34714         MSTJ(93)=1
34715         PM3=PYMASS(K(N+3,2))
34716         IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
34717      &  (PARJ(32)+PM2+PM3)**2) GOTO 630
34718         K(N+2,1)=1
34719         KFTEMP=K(N+2,2)
34720         CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
34721         IF(K(N+2,2).EQ.0) GOTO 260
34722         P(N+2,5)=PYMASS(K(N+2,2))
34723         PS=P(N+1,5)+P(N+2,5)
34724         PV(2,5)=P(N+2,5)
34725         MMAT=0
34726         ND=2
34727         GOTO 460
34728       ELSEIF(MMAT.EQ.44) THEN
34729         MSTJ(93)=1
34730         PM3=PYMASS(K(N+3,2))
34731         MSTJ(93)=1
34732         PM4=PYMASS(K(N+4,2))
34733         IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
34734      &  (PARJ(32)+PM3+PM4)**2) GOTO 600
34735         K(N+3,1)=1
34736         KFTEMP=K(N+3,2)
34737         CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
34738         IF(K(N+3,2).EQ.0) GOTO 260
34739         P(N+3,5)=PYMASS(K(N+3,2))
34740         DO 580 J=1,3
34741           P(N+3,J)=P(N+3,J)+P(N+4,J)
34742   580   CONTINUE
34743         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)
34744         HA=P(N+1,4)**2-P(N+2,4)**2
34745         HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
34746         HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
34747      &  (P(N+1,3)-P(N+2,3))**2
34748         HD=(PV(1,4)-P(N+3,4))**2
34749         HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
34750         HF=HD*HC-HB**2
34751         HG=HD*HC-HA*HB
34752         HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
34753         DO 590 J=1,3
34754           PCOR=HH*(P(N+1,J)-P(N+2,J))
34755           P(N+1,J)=P(N+1,J)+PCOR
34756           P(N+2,J)=P(N+2,J)-PCOR
34757   590   CONTINUE
34758         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)
34759         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)
34760         ND=ND-1
34761       ENDIF
34762
34763 C...Check invariant mass of W jets. May give one particle or start over.
34764   600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
34765      &.AND.IABS(K(N+1,2)).LT.10) THEN
34766         PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
34767         MSTJ(93)=1
34768         PM1=PYMASS(K(N+1,2))
34769         MSTJ(93)=1
34770         PM2=PYMASS(K(N+2,2))
34771         IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
34772         KFLDUM=INT(1.5D0+PYR(0))
34773         CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
34774         CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
34775         IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
34776         PSM=PYMASS(KF1)+PYMASS(KF2)
34777         IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
34778         IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
34779         IF(MMAT.EQ.48) GOTO 390
34780         IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
34781         K(N+1,1)=1
34782         KFTEMP=K(N+1,2)
34783         CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
34784         IF(K(N+1,2).EQ.0) GOTO 260
34785         P(N+1,5)=PYMASS(K(N+1,2))
34786         K(N+2,2)=K(N+3,2)
34787         P(N+2,5)=P(N+3,5)
34788         PS=P(N+1,5)+P(N+2,5)
34789         IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
34790         PV(2,5)=P(N+3,5)
34791         MMAT=0
34792         ND=2
34793         GOTO 460
34794       ENDIF
34795
34796 C...Phase space decay of partons from W decay.
34797   610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
34798         KFLO(1)=K(N+1,2)
34799         KFLO(2)=K(N+2,2)
34800         K(N+1,1)=K(N+3,1)
34801         K(N+1,2)=K(N+3,2)
34802         DO 620 J=1,5
34803           PV(1,J)=P(N+1,J)+P(N+2,J)
34804           P(N+1,J)=P(N+3,J)
34805   620   CONTINUE
34806         PV(1,5)=PMR
34807         N=N+1
34808         NP=0
34809         NQ=2
34810         PS=0D0
34811         MSTJ(93)=2
34812         PSQ=PYMASS(KFLO(1))
34813         MSTJ(93)=2
34814         PSQ=PSQ+PYMASS(KFLO(2))
34815         MMAT=11
34816         GOTO 290
34817       ENDIF
34818
34819 C...Boost back for rapidly moving particle.
34820   630 N=N+ND
34821       IF(MBST.EQ.1) THEN
34822         DO 640 J=1,3
34823           BE(J)=P(IP,J)/P(IP,4)
34824   640   CONTINUE
34825         GA=P(IP,4)/P(IP,5)
34826         DO 660 I=NSAV+1,N
34827           BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
34828           DO 650 J=1,3
34829             P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
34830   650     CONTINUE
34831           P(I,4)=GA*(P(I,4)+BEP)
34832   660   CONTINUE
34833       ENDIF
34834
34835 C...Fill in position of decay vertex.
34836       DO 680 I=NSAV+1,N
34837         DO 670 J=1,4
34838           V(I,J)=VDCY(J)
34839   670   CONTINUE
34840         V(I,5)=0D0
34841   680 CONTINUE
34842
34843 C...Set up for parton shower evolution from jets.
34844       IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
34845         K(NSAV+1,1)=3
34846         K(NSAV+2,1)=3
34847         K(NSAV+3,1)=3
34848         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34849         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34850         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34851         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34852         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34853         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34854         MSTJ(92)=-(NSAV+1)
34855       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
34856         K(NSAV+2,1)=3
34857         K(NSAV+3,1)=3
34858         K(NSAV+2,4)=MSTU(5)*(NSAV+3)
34859         K(NSAV+2,5)=MSTU(5)*(NSAV+3)
34860         K(NSAV+3,4)=MSTU(5)*(NSAV+2)
34861         K(NSAV+3,5)=MSTU(5)*(NSAV+2)
34862         MSTJ(92)=NSAV+2
34863       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34864      &  IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
34865         K(NSAV+1,1)=3
34866         K(NSAV+2,1)=3
34867         K(NSAV+1,4)=MSTU(5)*(NSAV+2)
34868         K(NSAV+1,5)=MSTU(5)*(NSAV+2)
34869         K(NSAV+2,4)=MSTU(5)*(NSAV+1)
34870         K(NSAV+2,5)=MSTU(5)*(NSAV+1)
34871         MSTJ(92)=NSAV+1
34872       ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
34873      &  IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
34874         MSTJ(92)=NSAV+1
34875       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
34876      &  THEN
34877         K(NSAV+1,1)=3
34878         K(NSAV+2,1)=3
34879         K(NSAV+3,1)=3
34880         KCP=PYCOMP(K(NSAV+1,2))
34881         KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
34882         JCON=4
34883         IF(KQP.LT.0) JCON=5
34884         K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
34885         K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
34886         K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
34887         K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
34888         MSTJ(92)=NSAV+1
34889       ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
34890         K(NSAV+1,1)=3
34891         K(NSAV+3,1)=3
34892         K(NSAV+1,4)=MSTU(5)*(NSAV+3)
34893         K(NSAV+1,5)=MSTU(5)*(NSAV+3)
34894         K(NSAV+3,4)=MSTU(5)*(NSAV+1)
34895         K(NSAV+3,5)=MSTU(5)*(NSAV+1)
34896         MSTJ(92)=NSAV+1
34897       ENDIF
34898
34899 C...Mark decayed particle; special option for B-Bbar mixing.
34900       IF(K(IP,1).EQ.5) K(IP,1)=15
34901       IF(K(IP,1).LE.10) K(IP,1)=11
34902       IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
34903       K(IP,4)=NSAV+1
34904       K(IP,5)=N
34905
34906       RETURN
34907       END
34908
34909 C*********************************************************************
34910
34911 *$ CREATE PYDCYK.FOR
34912 *COPY PYDCYK
34913 C...PYDCYK
34914 C...Handles flavour production in the decay of unstable particles
34915 C...and small string clusters.
34916
34917       SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
34918
34919 C...Double precision and integer declarations.
34920       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34921       INTEGER PYK,PYCHGE,PYCOMP
34922 C...Commonblocks.
34923       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34924       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34925       SAVE /PYDAT1/,/PYDAT2/
34926
34927
34928 C.. Call PYKFDI directly if no popcorn option is on
34929       IF(MSTJ(12).LT.2) THEN
34930          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34931          MSTU(124)=KFL3
34932          RETURN
34933       ENDIF
34934
34935       KFL3=0
34936       KF=0
34937       IF(KFL1.EQ.0) RETURN
34938       KF1A=IABS(KFL1)
34939       KF2A=IABS(KFL2)
34940
34941       NSTO=130
34942       NMAX=MIN(MSTU(125),10)
34943
34944 C.. Identify rank 0 cluster qq
34945       IRANK=1
34946       IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
34947
34948       IF(KF2A.GT.0)THEN
34949 C.. Join jets: Fails if store not empty
34950          IF(MSTU(121).GT.0) THEN
34951             MSTU(121)=0
34952             RETURN
34953          ENDIF
34954          CALL PYKFDI(KFL1,KFL2,KFL3,KF)
34955       ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
34956 C.. Pick popcorn meson from store, return same qq, decrease store
34957          KF=MSTU(NSTO+MSTU(121))
34958          KFL3=-KFL1
34959          MSTU(121)=MSTU(121)-1
34960       ELSE
34961 C.. Generate new flavour. Then done if no diquark is generated
34962   100    CALL PYKFDI(KFL1,0,KFL3,KF)
34963          IF(MSTU(121).EQ.-1) GOTO 100
34964          MSTU(124)=KFL3
34965          IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
34966
34967 C.. Simple case if no dynamical popcorn suppressions are considered
34968          IF(MSTJ(12).LT.4) THEN
34969             IF(MSTU(121).EQ.0) RETURN
34970             NMES=1
34971             KFPREV=-KFL3
34972             CALL PYKFDI(KFPREV,0,KFL3,KFM)
34973 C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
34974             IF(IABS(KFL3).LE.10)THEN
34975                KFL3=-KFPREV
34976                RETURN
34977             ENDIF
34978             GOTO 120
34979          ENDIF
34980
34981 C test output qq against fake Gamma, then return if no popcorn.
34982          GB=2D0
34983          IF(IRANK.NE.0)THEN
34984             CALL PYZDIS(1,2103,5D0,Z)
34985             GB=3D0*(1D0-Z)/Z
34986             IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
34987                MSTU(121)=0
34988                GOTO 100
34989             ENDIF
34990          ENDIF
34991          IF(MSTU(121).EQ.0) RETURN
34992
34993 C..Set store size memory. Pick fake dynamical variables of qq.
34994          NMES=MSTU(121)
34995          CALL PYPTDI(1,PX3,PY3)
34996          X=1D0
34997          POPM=0D0
34998          G=GB
34999          POPG=GB
35000
35001 C.. Pick next popcorn meson, test with fake dynamical variables
35002   110    KFPREV=-KFL3
35003          PX1=-PX3
35004          PY1=-PY3
35005          CALL PYKFDI(KFPREV,0,KFL3,KFM)
35006          IF(MSTU(121).EQ.-1) GOTO 100
35007          CALL PYPTDI(KFL3,PX3,PY3)
35008          PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
35009          CALL PYZDIS(KFPREV,KFL3,PM,Z)
35010          G=(1D0-Z)*(G+PM/Z)
35011          X=(1D0-Z)*X
35012
35013          PTST=1D0
35014          GTST=1D0
35015          RTST=PYR(0)
35016          IF(MSTJ(12).GT.4)THEN
35017             POPMN=SQRT((1D0-X)*(G/X-GB))
35018             POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35019             PTST=EXP((POPM-POPMN)*PARF(193))
35020             POPM=POPMN
35021          ENDIF
35022          IF(IRANK.NE.0)THEN
35023             POPGN=X*GB
35024             GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
35025             POPG=POPGN
35026          ENDIF
35027          IF(RTST.GT.PTST*GTST)THEN
35028             MSTU(121)=0
35029             IF(RTST.GT.PTST) MSTU(121)=-1
35030             GOTO 100
35031          ENDIF
35032
35033 C.. Store meson
35034   120    IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
35035          IF(MSTU(121).GT.0) GOTO 110
35036
35037 C.. Test accepted system size. If OK set global popcorn size variable.
35038          IF(NMES.GT.NMAX)THEN
35039             KF=0
35040             KFL3=0
35041             RETURN
35042          ENDIF
35043          MSTU(121)=NMES
35044       ENDIF
35045
35046       RETURN
35047       END
35048
35049 C********************************************************************
35050
35051 *$ CREATE PYKFDI.FOR
35052 *COPY PYKFDI
35053 C...PYKFDI
35054 C...Generates a new flavour pair and combines off a hadron
35055
35056       SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
35057
35058 C...Double precision and integer declarations.
35059       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35060       INTEGER PYK,PYCHGE,PYCOMP
35061 C...Commonblocks.
35062       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35063       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35064       SAVE /PYDAT1/,/PYDAT2/
35065 C...Local arrays.
35066       DIMENSION PD(7)
35067
35068       IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0)  CALL PYKFIN
35069
35070 C...Default flavour values. Input consistency checks.
35071       KF1A=IABS(KFL1)
35072       KF2A=IABS(KFL2)
35073       KFL3=0
35074       KF=0
35075       IF(KF1A.EQ.0) RETURN
35076       IF(KF2A.NE.0)THEN
35077         IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
35078         IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
35079         IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
35080       ENDIF
35081
35082 C...Check if tabulated flavour probabilities are to be used.
35083       IF(MSTJ(15).EQ.1) THEN
35084         IF(MSTJ(12).GE.5)  CALL PYERRM(29,
35085      &        '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
35086      &        ' together with MSTJ(12)>=5 modification')
35087         KTAB1=-1
35088         IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
35089         KFL1A=MOD(KF1A/1000,10)
35090         KFL1B=MOD(KF1A/100,10)
35091         KFL1S=MOD(KF1A,10)
35092         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
35093      &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
35094         IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
35095         IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
35096         KTAB2=0
35097         IF(KF2A.NE.0) THEN
35098           KTAB2=-1
35099           IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
35100           KFL2A=MOD(KF2A/1000,10)
35101           KFL2B=MOD(KF2A/100,10)
35102           KFL2S=MOD(KF2A,10)
35103           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
35104      &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
35105           IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
35106         ENDIF
35107         IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
35108       ENDIF
35109
35110 C.. Recognize rank 0 diquark case
35111   100 IRANK=1
35112       KFDIQ=MAX(KF1A,KF2A)
35113       IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
35114
35115 C.. Join two flavours to meson or baryon. Test for popcorn.
35116       IF(KF2A.GT.0)THEN
35117         MBARY=0
35118         IF(KFDIQ.GT.10) THEN
35119           IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
35120      &         CALL PYNMES(KFDIQ)
35121           IF(MSTU(121).NE.0) RETURN
35122           MBARY=2
35123         ENDIF
35124         KFQOLD=KF1A
35125         KFQVER=KF2A
35126         GOTO 130
35127       ENDIF
35128
35129 C.. Separate incoming flavours, curtain flavour consistency check
35130       KFIN=KFL1
35131       KFQOLD=KF1A
35132       KFQPOP=KF1A/10000
35133       IF(KF1A.GT.10)THEN
35134          KFIN=-KFL1
35135          KFL1A=MOD(KF1A/1000,10)
35136          KFL1B=MOD(KF1A/100,10)
35137          IF(IRANK.EQ.0)THEN
35138             QAWT=1D0
35139             IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
35140             IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
35141             KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
35142          ENDIF
35143          IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN
35144          KFQOLD=KFL1A+KFL1B-KFQPOP
35145       ENDIF
35146
35147 C...Meson/baryon choice. Set number of mesons if starting a popcorn
35148 C...system.
35149   110 MBARY=0
35150       IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
35151          IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
35152             MBARY=1
35153             CALL PYNMES(0)
35154          ENDIF
35155       ELSEIF(KF1A.GT.10)THEN
35156          MBARY=2
35157          IF(IRANK.EQ.0) CALL PYNMES(KF1A)
35158          IF(MSTU(121).GT.0) MBARY=-1
35159       ENDIF
35160
35161 C..x->H+q: Choose single vertex quark. Jump to form hadron.
35162       IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
35163          KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
35164          KFL3=ISIGN(KFQVER,-KFIN)
35165          GOTO 130
35166       ENDIF
35167
35168 C..x->H+qq: (IDW=proper PARF position for diquark weights)
35169       IDW=160
35170 C..   q->B+qq: Get curtain quark, different weights for q->B+B and
35171 C..   q->B+M+...
35172       IF(MBARY.EQ.1)THEN
35173          IF(MSTU(121).EQ.0) IDW=150
35174          SQWT=PARF(IDW+1)
35175          IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
35176          KFQPOP=1+INT((2D0+SQWT)*PYR(0))
35177 C..   Shift to s-curtain parameters if needed
35178          IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
35179             PARF(194)=PARF(138)*PARF(139)
35180             PARF(193)=PARJ(8)+PARJ(9)
35181          ENDIF
35182       ENDIF
35183
35184 C.. x->H+qq: Get vertex quark
35185       IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35186          IDW=MSTU(122)
35187          MSTU(121)=MSTU(121)-1
35188          IF(IDW.EQ.170) THEN
35189             IF(MSTU(121).EQ.0)THEN
35190                IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
35191             ELSE
35192                IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
35193             ENDIF
35194          ELSE
35195             IF(MSTU(121).EQ.0)THEN
35196                IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
35197             ELSE
35198                IPOS=3*5+5*4+MIN(KFQOLD-1,4)
35199             ENDIF
35200          ENDIF
35201          IPOS=200+30*IPOS+1
35202
35203          IMES=-1
35204          RMES=PYR(0)*PARF(194)
35205   120    IMES=IMES+1
35206          RMES=RMES-PARF(IPOS+IMES)
35207          IF(IMES.EQ.30) THEN
35208             MSTU(121)=-1
35209             KF=-111
35210             RETURN
35211          ENDIF
35212          IF(RMES.GT.0D0) GOTO 120
35213          KMUL=IMES/5
35214          KFJ=2*KMUL+1
35215          IF(KMUL.EQ.2) KFJ=10003
35216          IF(KMUL.EQ.3) KFJ=10001
35217          IF(KMUL.EQ.4) KFJ=20003
35218          IF(KMUL.EQ.5) KFJ=5
35219          IDIAG=0
35220          KFQVER=MOD(IMES,5)+1
35221          IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
35222          IF(KFQVER.GT.3)THEN
35223             IDIAG=KFQVER-3
35224             KFQVER=KFQOLD
35225          ENDIF
35226       ELSE
35227          IF(MBARY.EQ.-1) IDW=170
35228          SQWT=PARF(IDW+2)
35229          IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
35230          IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
35231          KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
35232          IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
35233             KFQVER=KFQPOP
35234             IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
35235          ENDIF
35236       ENDIF
35237
35238 C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
35239       KFLDS=3
35240       IF(KFQPOP.NE.KFQVER)THEN
35241          SWT=PARF(IDW+7)
35242          IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
35243          IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
35244          IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
35245       ENDIF
35246       KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
35247      &      +10000*KFQPOP
35248       KFL3=ISIGN(KFDIQ,KFIN)
35249
35250 C..x->M+y: flavour for meson.
35251   130 IF(MBARY.LE.0)THEN
35252         KFLA=MAX(KFQOLD,KFQVER)
35253         KFLB=MIN(KFQOLD,KFQVER)
35254         KFS=ISIGN(1,KFL1)
35255         IF(KFLA.NE.KFQOLD) KFS=-KFS
35256 C... Form meson, with spin and flavour mixing for diagonal states.
35257         IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
35258            IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
35259            IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
35260            RETURN
35261         ENDIF
35262         IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
35263         IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
35264         IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
35265         IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
35266           IF(PYR(0).LT.PARJ(14)) KMUL=2
35267         ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
35268           RMUL=PYR(0)
35269           IF(RMUL.LT.PARJ(15)) KMUL=3
35270           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
35271           IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
35272         ENDIF
35273         KFLS=3
35274         IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
35275         IF(KMUL.EQ.5) KFLS=5
35276         IF(KFLA.NE.KFLB)THEN
35277           KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
35278         ELSE
35279           RMIX=PYR(0)
35280           IMIX=2*KFLA+10*KMUL
35281           IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
35282      &    INT(RMIX+PARF(IMIX)))+KFLS
35283           IF(KFLA.GE.4) KF=110*KFLA+KFLS
35284         ENDIF
35285         IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
35286         IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
35287
35288 C..Optional extra suppression of eta and eta'.
35289 C..Allow shift to qq->B+q in old version (set IRANK to 0)
35290         IF(KF.EQ.221.OR.KF.EQ.331)THEN
35291            IF(PYR(0).GT.PARJ(25+KF/300))THEN
35292               IF(KF2A.GT.0) GOTO 130
35293               IF(MSTJ(12).LT.4) IRANK=0
35294               GOTO 110
35295            ENDIF
35296         ENDIF
35297         MSTU(121)=0
35298
35299 C.. x->B+y: Flavour for baryon
35300       ELSE
35301         KFLA=KFQVER
35302         IF(KF1A.LE.10) KFLA=KFQOLD
35303         KFLB=MOD(KFDIQ/1000,10)
35304         KFLC=MOD(KFDIQ/100,10)
35305         KFLDS=MOD(KFDIQ,10)
35306         KFLD=MAX(KFLA,KFLB,KFLC)
35307         KFLF=MIN(KFLA,KFLB,KFLC)
35308         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35309
35310 C...  SU(6) factors for formation of baryon.
35311         KBARY=3
35312         KDMAX=5
35313         KFLG=KFLB
35314         IF(KFLB.NE.KFLC)THEN
35315            KBARY=2*KFLDS-1
35316            KDMAX=1+KFLDS/2
35317            IF(KFLB.GT.2) KDMAX=KDMAX+2
35318         ENDIF
35319         IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
35320            KBARY=KBARY+1
35321            KFLG=KFLA
35322         ENDIF
35323
35324         SU6MAX=PARF(140+KDMAX)
35325         SU6DEC=PARJ(18)
35326         SU6S  =PARF(146)
35327         IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
35328            SU6MAX=1D0
35329            SU6DEC=1D0
35330            SU6S  =1D0
35331         ENDIF
35332         SU6OCT=PARF(60+KBARY)
35333         IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
35334            SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
35335            IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
35336         ELSE
35337            IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
35338         ENDIF
35339         SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
35340
35341 C..   SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
35342         IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
35343            MSTU(121)=0
35344            IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
35345            GOTO 110
35346         ENDIF
35347
35348 C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
35349         KSIG=1
35350         KFLS=2
35351         IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
35352         IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
35353           KSIG=KFLDS/3
35354           IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
35355         ENDIF
35356         KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
35357         IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
35358       ENDIF
35359       RETURN
35360
35361 C...Use tabulated probabilities to select new flavour and hadron.
35362   140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
35363         KT3L=1
35364         KT3U=6
35365       ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
35366         KT3L=1
35367         KT3U=6
35368       ELSEIF(KTAB2.EQ.0) THEN
35369         KT3L=1
35370         KT3U=22
35371       ELSE
35372         KT3L=KTAB2
35373         KT3U=KTAB2
35374       ENDIF
35375       RFL=0D0
35376       DO 160 KTS=0,2
35377         DO 150 KT3=KT3L,KT3U
35378           RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
35379   150   CONTINUE
35380   160 CONTINUE
35381       RFL=PYR(0)*RFL
35382       DO 180 KTS=0,2
35383         KTABS=KTS
35384         DO 170 KT3=KT3L,KT3U
35385           KTAB3=KT3
35386           RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
35387           IF(RFL.LE.0D0) GOTO 190
35388   170   CONTINUE
35389   180 CONTINUE
35390   190 CONTINUE
35391
35392 C...Reconstruct flavour of produced quark/diquark.
35393       IF(KTAB3.LE.6) THEN
35394         KFL3A=KTAB3
35395         KFL3B=0
35396         KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
35397       ELSE
35398         KFL3A=1
35399         IF(KTAB3.GE.8) KFL3A=2
35400         IF(KTAB3.GE.11) KFL3A=3
35401         IF(KTAB3.GE.16) KFL3A=4
35402         KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
35403         KFL3=1000*KFL3A+100*KFL3B+1
35404         IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
35405      &  KFL3+2
35406         KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
35407       ENDIF
35408
35409 C...Reconstruct meson code.
35410       IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
35411      &KFL3B.NE.0)) THEN
35412         RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35413      &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
35414         KF=110+2*KTABS+1
35415         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
35416         IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
35417      &  25*KTABS)) KF=330+2*KTABS+1
35418       ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
35419         KFLA=MAX(KTAB1,KTAB3)
35420         KFLB=MIN(KTAB1,KTAB3)
35421         KFS=ISIGN(1,KFL1)
35422         IF(KFLA.NE.KF1A) KFS=-KFS
35423         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35424       ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
35425         KFS=ISIGN(1,KFL1)
35426         IF(KFL1A.EQ.KFL3A) THEN
35427           KFLA=MAX(KFL1B,KFL3B)
35428           KFLB=MIN(KFL1B,KFL3B)
35429           IF(KFLA.NE.KFL1B) KFS=-KFS
35430         ELSEIF(KFL1A.EQ.KFL3B) THEN
35431           KFLA=KFL3A
35432           KFLB=KFL1B
35433           KFS=-KFS
35434         ELSEIF(KFL1B.EQ.KFL3A) THEN
35435           KFLA=KFL1A
35436           KFLB=KFL3B
35437         ELSEIF(KFL1B.EQ.KFL3B) THEN
35438           KFLA=MAX(KFL1A,KFL3A)
35439           KFLB=MIN(KFL1A,KFL3A)
35440           IF(KFLA.NE.KFL1A) KFS=-KFS
35441         ELSE
35442           CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
35443           GOTO 100
35444         ENDIF
35445         KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
35446
35447 C...Reconstruct baryon code.
35448       ELSE
35449         IF(KTAB1.GE.7) THEN
35450           KFLA=KFL3A
35451           KFLB=KFL1A
35452           KFLC=KFL1B
35453         ELSE
35454           KFLA=KFL1A
35455           KFLB=KFL3A
35456           KFLC=KFL3B
35457         ENDIF
35458         KFLD=MAX(KFLA,KFLB,KFLC)
35459         KFLF=MIN(KFLA,KFLB,KFLC)
35460         KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
35461         IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
35462         IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
35463       ENDIF
35464
35465 C...Check that constructed flavour code is an allowed one.
35466       IF(KFL2.NE.0) KFL3=0
35467       KC=PYCOMP(KF)
35468       IF(KC.EQ.0) THEN
35469         CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
35470      &  'failed')
35471         GOTO 100
35472       ENDIF
35473
35474       RETURN
35475       END
35476
35477 C*********************************************************************
35478
35479 *$ CREATE PYNMES.FOR
35480 *COPY PYNMES
35481 C...PYNMES
35482 C...Generates number of popcorn mesons and stores some relevant
35483 C...parameters.
35484
35485       SUBROUTINE PYNMES(KFDIQ)
35486
35487 C...Double precision and integer declarations.
35488       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35489       INTEGER PYK,PYCHGE,PYCOMP
35490 C...Commonblocks.
35491       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35492       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35493       SAVE /PYDAT1/,/PYDAT2/
35494
35495       MSTU(121)=0
35496       IF(MSTJ(12).LT.2) RETURN
35497
35498 C..Old version: Get 1 or 0 popcorn mesons
35499       IF(MSTJ(12).LT.5)THEN
35500          POPWT=PARF(131)
35501          IF(KFDIQ.NE.0) THEN
35502             KFDIQA=IABS(KFDIQ)
35503             KFA=MOD(KFDIQA/1000,10)
35504             KFB=MOD(KFDIQA/100,10)
35505             KFS=MOD(KFDIQA,10)
35506             POPWT=PARF(132)
35507             IF(KFA.EQ.3) POPWT=PARF(133)
35508             IF(KFB.EQ.3) POPWT=PARF(134)
35509             IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
35510          ENDIF
35511          MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
35512          RETURN
35513       ENDIF
35514
35515 C..New version: Store popcorn- or rank 0 diquark parameters
35516       MSTU(122)=170
35517       PARF(193)=PARJ(8)
35518       PARF(194)=PARF(139)
35519       IF(KFDIQ.NE.0) THEN
35520          MSTU(122)=180
35521          PARF(193)=PARJ(10)
35522          PARF(194)=PARF(140)
35523       ENDIF
35524       IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
35525          IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
35526      &        '(PYNMES:) Neglecting too large popcorn possibility')
35527          RETURN
35528       ENDIF
35529
35530 C..New version: Get number of popcorn mesons
35531   100 RTST=PYR(0)
35532       MSTU(121)=-1
35533   110 MSTU(121)=MSTU(121)+1
35534       RTST=RTST/PARF(194)
35535       IF(RTST.LT.1D0) GOTO 110
35536       IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT.
35537      &     (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100
35538       RETURN
35539       END
35540
35541 C*********************************************************************
35542
35543 *$ CREATE PYKFIN.FOR
35544 *COPY PYKFIN
35545 C...PYKFIN
35546 C...Precalculates a set of diquark and popcorn weights.
35547 C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1)
35548
35549       SUBROUTINE PYKFIN
35550
35551 C...Double precision and integer declarations.
35552       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35553       INTEGER PYK,PYCHGE,PYCOMP
35554 C...Commonblocks.
35555       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35556       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35557       SAVE /PYDAT1/,/PYDAT2/
35558
35559       DIMENSION SU6(12),SU6M(7)
35560
35561       MSTU(123)=1
35562 C..Curtain tunneling factor T(D,q)/T(ud0,u).
35563       IF(MSTJ(12).GE.5) THEN
35564          PMUD0=PYMASS(2101)
35565          PMUD1=PYMASS(2103)-PMUD0
35566          PMUS0=PYMASS(3201)-PMUD0
35567          PMUS1=PYMASS(3203)-PMUS0-PMUD0
35568          PMSS1=PYMASS(3303)-PMUS0-PMUD0
35569          PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
35570          PARF(152)=EXP(-PARJ(8)*PMUS0)
35571          PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151)
35572          PARF(154)=EXP(-PARJ(8)*PMUD1)
35573          PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151)
35574          PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152)
35575          PARF(157)=PARF(154)
35576       ELSE
35577          PAR2M=SQRT(PARJ(2))
35578          PAR3M=SQRT(PARJ(3))
35579          PAR4M=SQRT(PARJ(4))
35580          PARF(151)=PAR2M*PAR3M
35581          PARF(152)=PAR3M
35582          PARF(153)=PAR2M*PARJ(3)*PAR4M
35583          PARF(154)=PAR4M
35584          PARF(155)=PAR4M*PARF(151)
35585          PARF(156)=PAR4M*PARF(152)
35586          PARF(157)=PAR4M
35587       ENDIF
35588
35589 C.. Total tunneling factor tau(D,q)=T*vertex*spin.
35590       PARF(161)=PARF(151)
35591       PARF(162)=PARJ(2)*PARF(152)
35592       PARF(163)=PARJ(2)*6D0*PARF(153)
35593       PARF(164)=6D0*PARF(154)
35594       PARF(165)=3D0*PARF(155)
35595       PARF(166)=PARJ(2)*3D0*PARF(156)
35596       PARF(167)=3D0*PARF(157)
35597
35598       DO 100 I=1,7
35599          PARF(150+I)=PARF(150+I)*PARF(160+I)
35600   100 CONTINUE
35601
35602 C..Modified SU(6) factors.
35603       PARF(146)=1D0
35604       IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
35605       IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
35606      &     '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
35607       DO 110 I=1,6
35608          SU6(I)=PARF(60+I)
35609          SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
35610   110 CONTINUE
35611       SU6(8)=SU6(2)*4/(3*PARF(146)+1)
35612       SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
35613       DO 120 I=1,6
35614          SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
35615          SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
35616   120 CONTINUE
35617
35618 C..Total diquark quark*SU(6).
35619       PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
35620       PARF(171)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
35621       PARF(172)=PARF(171)
35622       PARF(173)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
35623       PARF(174)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
35624       PARF(175)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
35625       PARF(176)=PARF(175)
35626       PARF(177)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
35627
35628 C..SU(6)max         q       q'     s,c,b
35629       SU6MUD =MAX(SU6(1) ,       SU6(8) )
35630       SU6M(7)=MAX(SU6(5) ,       SU6(12))
35631       SU6M(1)=MAX(SU6(7) ,SU6(2),SU6MUD )
35632       SU6M(4)=MAX(SU6(3) ,SU6(4),SU6(10))
35633       SU6M(5)=MAX(SU6(11),SU6(6),SU6M(7))
35634       SU6M(2)=SU6M(1)
35635       SU6M(3)=SU6M(4)
35636       SU6M(6)=SU6M(5)
35637
35638       IF(MSTJ(12).GE.5)THEN
35639 C..New version: tau for rank 0 diquark.
35640          PARF(181)=EXP(-PARJ(10)*PMUS0)
35641          PARF(182)=PARJ(2)*PARF(181)
35642          PARF(183)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*PARF(181)
35643          PARF(184)=3D0*EXP(-PARJ(10)*PMUD1)
35644          PARF(185)=3D0*EXP(-PARJ(10)*PMUS1)*PARF(181)
35645          PARF(186)=PARJ(2)*PARF(185)
35646          PARF(187)=2D0*PARF(184)
35647
35648 C..New version: s/u curtain ratios.
35649          WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35650          PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35651          WU=1D0+PARF(187)+PARF(182)+PARF(186)+PARF(184)
35652          PARF(136)=(2D0*(PARF(181)+PARF(185))+PARF(183))/WU
35653          PARF(137)=(PARF(181)+PARF(185))*
35654      &        (2D0+PARF(183)/(2D0*PARF(185)))/WU
35655       ELSE
35656 C..Old version: Shuffle PARJ(7) into tau
35657          PARF(162)=PARF(162)*PARJ(7)
35658          PARF(163)=PARF(163)*PARJ(7)
35659          PARF(166)=PARF(166)*PARJ(7)
35660
35661 C..Old version: s/u curtain ratios.
35662          WU=1D0+PARF(167)+PARF(162)+PARF(166)+PARF(164)
35663          PARF(135)=(2D0*(PARF(161)+PARF(165))+PARF(163))/WU
35664          PARF(136)=PARF(135)*PARJ(6)*PARF(161)/PARF(162)
35665          PARF(137)=(1D0+PARF(167))*(2D0+PARF(162))/WU
35666       ENDIF
35667
35668 C..Combine SU(6), SU(6)max, tau and T into proper products
35669       DO 140 I=1,7
35670          PARF(180+I)=PARF(180+I)*PARF(170+I)
35671          PARF(170+I)=PARF(170+I)*PARF(160+I)
35672          PARF(160+I)=PARF(160+I)*SU6M(I)/SU6MUD
35673          PARF(150+I)=PARF(150+I)*SU6M(I)/SU6MUD
35674   140 CONTINUE
35675
35676 C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
35677       PARF(141)=SU6MUD
35678       PARF(142)=SU6M(7)
35679       PARF(143)=SU6M(1)
35680       PARF(144)=SU6M(5)
35681       PARF(145)=SU6M(3)
35682
35683       IF(MSTJ(12).LT.5)THEN
35684 C.. Old version: Resulting popcorn weights.
35685          PARF(138)=PARJ(6)
35686          WS=PARF(135)*PARF(138)
35687          WQ=WU*PARJ(5)/3D0
35688          PARF(132)=WQ*PARF(167)/PARF(157)
35689          PARF(133)=WQ*(PARF(166)/PARF(156)+WS*PARF(165)/PARF(155))/2D0
35690          PARF(134)=WQ*WS*PARF(163)/PARF(153)
35691          PARF(131)=WQ*((1D0+PARF(167))*(1D0+PARF(162)+WS*PARF(161))+
35692      &     PARF(164)+WS*PARF(163)/2D0)/
35693      &    ((1D0+PARF(157))*(1D0+2D0*PARF(152))+PARF(154)+PARF(153)/2D0)
35694       ELSE
35695 C..New version: Store weights for popcorn mesons,
35696 C..get prel. popcorn weights.
35697          DO 150 IPOS=201,1400
35698             PARF(IPOS)=0D0
35699   150    CONTINUE
35700          DO 160 I=138,140
35701             PARF(I)=0D0
35702   160    CONTINUE
35703          IPOS=200
35704          PARF(193)=PARJ(8)
35705          DO 240 MR=170,180,10
35706            IF(MR.EQ.180) PARF(193)=PARJ(10)
35707            SQWT=2D0*(PARF(MR+2)+PARF(MR+6))/(1D0+PARF(MR+7)+PARF(MR+4))
35708            QQWT=PARF(MR+4)/(1D0+PARF(MR+7)+PARF(MR+4))
35709            DO 230 NMES=0,1
35710              IF(NMES.EQ.1) SQWT=PARJ(2)
35711              DO 220 KFQPOP=1,4
35712                IF(MR.EQ.170.AND.KFQPOP.GT.3) GOTO 220
35713                IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
35714                   SQWT=PARF(MR+3)/(PARF(MR+1)+PARF(MR+5))
35715                   QQWT=0.5D0
35716                   IF(MR.EQ.170) PARF(193)=PARJ(8)+PARJ(9)
35717                   IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/PARF(185)+1D0)/2D0
35718                ENDIF
35719                DO 210 KFQOLD =1,5
35720                   IF(MR.EQ.170.AND.KFQOLD.GT.3) GOTO 210
35721                   IF(MR*NMES.EQ.170.AND.KFQPOP.EQ.1) GOTO 210
35722                   IF(MR*NMES.EQ.180.AND.KFQPOP.NE.1) GOTO 210
35723                   WTTOT=0D0
35724                   WTFAIL=0D0
35725       DO 190 KMUL=0,5
35726          PJWT=PARJ(12+KMUL)
35727          IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
35728          IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
35729          IF(PJWT.LE.0D0) GOTO 190
35730          IF(PJWT.GT.1D0) PJWT=1D0
35731          IMES=5*KMUL
35732          IMIX=2*KFQOLD+10*KMUL
35733          KFJ=2*KMUL+1
35734          IF(KMUL.EQ.2) KFJ=10003
35735          IF(KMUL.EQ.3) KFJ=10001
35736          IF(KMUL.EQ.4) KFJ=20003
35737          IF(KMUL.EQ.5) KFJ=5
35738          DO 180 KFQVER =1,3
35739             KFLA=MAX(KFQOLD,KFQVER)
35740             KFLB=MIN(KFQOLD,KFQVER)
35741             SWT=PARJ(11+KFLA/3+KFLA/4)
35742             IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
35743             SWT=SWT*PJWT
35744             QWT=SQWT/(2D0+SQWT)
35745             IF(KFQVER.LT.3)THEN
35746                IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
35747                IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
35748             ENDIF
35749             IF(KFQVER.NE.KFQOLD)THEN
35750                IMES=IMES+1
35751                KFM=100*KFLA+10*KFLB+KFJ
35752                PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35753                PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
35754                WTTOT=WTTOT+PARF(IPOS+IMES)
35755             ELSE
35756                DO 170 ID=3,5
35757                   IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
35758                   IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
35759                   IF(ID.EQ.5) DWT=PARF(IMIX)
35760                   KFM=110*(ID-2)+KFJ
35761                   PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
35762                   PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
35763                   IF(KMUL.EQ.0.AND.ID.GT.3) THEN
35764                      WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
35765                      PARF(IPOS+5*KMUL+ID)=
35766      &                    PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
35767                   ENDIF
35768                   WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
35769   170          CONTINUE
35770             ENDIF
35771   180    CONTINUE
35772   190 CONTINUE
35773                   DO 200 IMES=1,30
35774                      PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
35775   200             CONTINUE
35776                   IF(MR.EQ.180) PARF(140)=
35777      &                 MAX(PARF(140),WTTOT/(1D0-WTFAIL))
35778                   IF(MR.EQ.170) PARF(139-KFQPOP/3)=
35779      &                 MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
35780                   IPOS=IPOS+30
35781   210           CONTINUE
35782   220         CONTINUE
35783   230       CONTINUE
35784   240    CONTINUE
35785          IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
35786          MSTU(121)=0
35787
35788          PARF(186)=PARF(186)/PARF(182)
35789          PARF(185)=PARF(185)/PARF(181)
35790       ENDIF
35791
35792 C..Recombine diquark weights to flavour and spin ratios
35793       DO 250 I=150,170,10
35794          WSWQ=(2D0*(PARF(I+1)+PARF(I+5))+PARF(I+3))/
35795      &        (1D0+PARF(I+7)+PARF(I+4)+PARF(I+2)+PARF(I+6))
35796          WSSWSQ=PARF(I+3)/(PARF(I+1)+PARF(I+5))
35797          WQSWQQ=2D0*(PARF(I+2)+PARF(I+6))/(1D0+PARF(I+7)+PARF(I+4))
35798          WUUWQQ=PARF(I+4)/(1D0+PARF(I+7)+PARF(I+4))
35799          PARF(I+5)=PARF(I+5)/PARF(I+1)
35800          PARF(I+6)=PARF(I+6)/PARF(I+2)
35801          PARF(I+1)=WSWQ
35802          PARF(I+2)=WQSWQQ
35803          PARF(I+3)=WSSWSQ
35804          PARF(I+4)=WUUWQQ
35805   250 CONTINUE
35806       RETURN
35807       END
35808
35809 C*********************************************************************
35810
35811 *$ CREATE PYPTDI.FOR
35812 *COPY PYPTDI
35813 C...PYPTDI
35814 C...Generates transverse momentum according to a Gaussian.
35815
35816       SUBROUTINE PYPTDI(KFL,PX,PY)
35817
35818 C...Double precision and integer declarations.
35819       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35820       INTEGER PYK,PYCHGE,PYCOMP
35821 C...Commonblocks.
35822       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35823       SAVE /PYDAT1/
35824
35825 C...Generate p_T and azimuthal angle, gives p_x and p_y.
35826       KFLA=IABS(KFL)
35827       PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
35828       IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
35829       IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
35830       IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
35831       PHI=PARU(2)*PYR(0)
35832       PX=PT*COS(PHI)
35833       PY=PT*SIN(PHI)
35834
35835       RETURN
35836       END
35837
35838 C*********************************************************************
35839
35840 *$ CREATE PYZDIS.FOR
35841 *COPY PYZDIS
35842 C...PYZDIS
35843 C...Generates the longitudinal splitting variable z.
35844
35845       SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
35846
35847 C...Double precision and integer declarations.
35848       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35849       INTEGER PYK,PYCHGE,PYCOMP
35850 C...Commonblocks.
35851       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35852       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35853       SAVE /PYDAT1/,/PYDAT2/
35854
35855 C...Check if heavy flavour fragmentation.
35856       KFLA=IABS(KFL1)
35857       KFLB=IABS(KFL2)
35858       KFLH=KFLA
35859       IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
35860
35861 C...Lund symmetric scaling function: determine parameters of shape.
35862       IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
35863      &MSTJ(11).GE.4) THEN
35864         FA=PARJ(41)
35865         IF(MSTJ(91).EQ.1) FA=PARJ(43)
35866         IF(KFLB.GE.10) FA=FA+PARJ(45)
35867         FBB=PARJ(42)
35868         IF(MSTJ(91).EQ.1) FBB=PARJ(44)
35869         FB=FBB*PR
35870         FC=1D0
35871         IF(KFLA.GE.10) FC=FC-PARJ(45)
35872         IF(KFLB.GE.10) FC=FC+PARJ(45)
35873         IF(MSTJ(11).GE.4.AND.KFLH.GE.4.AND.KFLH.LE.5) THEN
35874           FRED=PARJ(46)
35875           IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
35876           FC=FC+FRED*FBB*PARF(100+KFLH)**2
35877         ELSEIF(MSTJ(11).GE.4.AND.KFLH.GE.6.AND.KFLH.LE.8) THEN
35878           FRED=PARJ(46)
35879           IF(MSTJ(11).EQ.5) FRED=PARJ(48)
35880           FC=FC+FRED*FBB*PMAS(KFLH,1)**2
35881         ENDIF
35882         MC=1
35883         IF(ABS(FC-1D0).GT.0.01D0) MC=2
35884
35885 C...Determine position of maximum. Special cases for a = 0 or a = c.
35886         IF(FA.LT.0.02D0) THEN
35887           MA=1
35888           ZMAX=1D0
35889           IF(FC.GT.FB) ZMAX=FB/FC
35890         ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
35891           MA=2
35892           ZMAX=FB/(FB+FC)
35893         ELSE
35894           MA=3
35895           ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
35896           IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
35897         ENDIF
35898
35899 C...Subdivide z range if distribution very peaked near endpoint.
35900         MMAX=2
35901         IF(ZMAX.LT.0.1D0) THEN
35902           MMAX=1
35903           ZDIV=2.75D0*ZMAX
35904           IF(MC.EQ.1) THEN
35905             FINT=1D0-LOG(ZDIV)
35906           ELSE
35907             ZDIVC=ZDIV**(1D0-FC)
35908             FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
35909           ENDIF
35910         ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
35911           MMAX=3
35912           FSCB=SQRT(4D0+(FC/FB)**2)
35913           ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
35914           IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
35915           ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
35916           FINT=1D0+FB*(1D0-ZDIV)
35917         ENDIF
35918
35919 C...Choice of z, preweighted for peaks at low or high z.
35920   100   Z=PYR(0)
35921         FPRE=1D0
35922         IF(MMAX.EQ.1) THEN
35923           IF(FINT*PYR(0).LE.1D0) THEN
35924             Z=ZDIV*Z
35925           ELSEIF(MC.EQ.1) THEN
35926             Z=ZDIV**Z
35927             FPRE=ZDIV/Z
35928           ELSE
35929             Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
35930             FPRE=(ZDIV/Z)**FC
35931           ENDIF
35932         ELSEIF(MMAX.EQ.3) THEN
35933           IF(FINT*PYR(0).LE.1D0) THEN
35934             Z=ZDIV+LOG(Z)/FB
35935             FPRE=EXP(FB*(Z-ZDIV))
35936           ELSE
35937             Z=ZDIV+Z*(1D0-ZDIV)
35938           ENDIF
35939         ENDIF
35940
35941 C...Weighting according to correct formula.
35942         IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
35943         FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
35944         IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
35945         FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
35946         IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
35947
35948 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
35949       ELSE
35950         FC=PARJ(50+MAX(1,KFLH))
35951         IF(MSTJ(91).EQ.1) FC=PARJ(59)
35952   110   Z=PYR(0)
35953         IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
35954           IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
35955         ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
35956           IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
35957      &    GOTO 110
35958         ELSE
35959           IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
35960           IF(FC.LT.0D0) Z=Z**(-1D0/FC)
35961         ENDIF
35962       ENDIF
35963
35964       RETURN
35965       END
35966
35967 C*********************************************************************
35968
35969 *$ CREATE PYSHOW.FOR
35970 *COPY PYSHOW
35971 C...PYSHOW
35972 C...Generates timelike parton showers from given partons.
35973
35974       SUBROUTINE PYSHOW(IP1,IP2,QMAX)
35975
35976 C...Double precision and integer declarations.
35977       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35978       INTEGER PYK,PYCHGE,PYCOMP
35979 C...Commonblocks.
35980       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
35981       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35982       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35983       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
35984 C...Local arrays.
35985       DIMENSION PMTH(5,50),PS(5),PMA(4),PMSD(4),IEP(4),IPA(4),
35986      &KFLA(4),KFLD(4),KFL(4),ITRY(4),ISI(4),ISL(4),DP(4),DPT(5,4),
35987      &KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),PHIIIS(2,2),
35988      &ISII(2)
35989
35990 C...Initialization of cutoff masses etc.
35991       IF(MSTJ(41).LE.0.OR.(MSTJ(41).EQ.1.AND.QMAX.LE.PARJ(82)).OR.
35992      &QMAX.LE.MIN(PARJ(82),PARJ(83))) RETURN
35993       DO 100 IFL=0,40
35994         KSH(IFL)=0
35995   100 CONTINUE
35996       KSH(21)=1
35997       PMTH(1,21)=PYMASS(21)
35998       PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
35999       PMTH(3,21)=2D0*PMTH(2,21)
36000       PMTH(4,21)=PMTH(3,21)
36001       PMTH(5,21)=PMTH(3,21)
36002       PMTH(1,22)=PYMASS(22)
36003       PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
36004       PMTH(3,22)=2D0*PMTH(2,22)
36005       PMTH(4,22)=PMTH(3,22)
36006       PMTH(5,22)=PMTH(3,22)
36007       PMQTH1=PARJ(82)
36008       IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
36009       PMQTH2=PMTH(2,21)
36010       IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
36011       DO 110 IFL=1,8
36012         KSH(IFL)=1
36013         PMTH(1,IFL)=PYMASS(IFL)
36014         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
36015         PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
36016         PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
36017         PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
36018   110 CONTINUE
36019       DO 120 IFL=11,17,2
36020         IF(MSTJ(41).GE.2) KSH(IFL)=1
36021         PMTH(1,IFL)=PYMASS(IFL)
36022         PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)
36023         PMTH(3,IFL)=PMTH(2,IFL)+PMTH(2,22)
36024         PMTH(4,IFL)=PMTH(3,IFL)
36025         PMTH(5,IFL)=PMTH(3,IFL)
36026   120 CONTINUE
36027       PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
36028       ALAMS=PARJ(81)**2
36029       ALFM=LOG(PT2MIN/ALAMS)
36030
36031 C...Store positions of shower initiating partons.
36032       IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
36033         NPA=1
36034         IPA(1)=IP1
36035       ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
36036      &  MSTU(32))) THEN
36037         NPA=2
36038         IPA(1)=IP1
36039         IPA(2)=IP2
36040       ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
36041      &  .AND.IP2.GE.-3) THEN
36042         NPA=IABS(IP2)
36043         DO 130 I=1,NPA
36044           IPA(I)=IP1+I-1
36045   130   CONTINUE
36046       ELSE
36047         CALL PYERRM(12,
36048      &  '(PYSHOW:) failed to reconstruct showering system')
36049         IF(MSTU(21).GE.1) RETURN
36050       ENDIF
36051
36052 C...Check on phase space available for emission.
36053       IREJ=0
36054       DO 140 J=1,5
36055         PS(J)=0D0
36056   140 CONTINUE
36057       PM=0D0
36058       DO 160 I=1,NPA
36059         KFLA(I)=IABS(K(IPA(I),2))
36060         PMA(I)=P(IPA(I),5)
36061 C...Special cutoff masses for t, l, h with variable masses.
36062         IFLA=KFLA(I)
36063         IF(KFLA(I).GE.6.AND.KFLA(I).LE.8) THEN
36064           IFLA=37+KFLA(I)+ISIGN(2,K(IPA(I),2))
36065           PMTH(1,IFLA)=PMA(I)
36066           PMTH(2,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PMQTH1**2)
36067           PMTH(3,IFLA)=PMTH(2,IFLA)+PMQTH2
36068           PMTH(4,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(82)**2)+
36069      &    PMTH(2,21)
36070           PMTH(5,IFLA)=SQRT(PMTH(1,IFLA)**2+0.25D0*PARJ(83)**2)+
36071      &    PMTH(2,22)
36072         ENDIF
36073         IF(KFLA(I).LE.40) THEN
36074           IF(KSH(KFLA(I)).EQ.1) PMA(I)=PMTH(3,IFLA)
36075         ENDIF
36076         PM=PM+PMA(I)
36077         IF(KFLA(I).GT.40) THEN
36078           IREJ=IREJ+1
36079         ELSE
36080           IF(KSH(KFLA(I)).EQ.0.OR.PMA(I).GT.QMAX) IREJ=IREJ+1
36081         ENDIF
36082         DO 150 J=1,4
36083           PS(J)=PS(J)+P(IPA(I),J)
36084   150   CONTINUE
36085   160 CONTINUE
36086       IF(IREJ.EQ.NPA) RETURN
36087       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
36088       IF(NPA.EQ.1) PS(5)=PS(4)
36089       IF(PS(5).LE.PM+PMQTH1) RETURN
36090
36091 C...Check if 3-jet matrix elements to be used.
36092       M3JC=0
36093       IF(NPA.EQ.2.AND.MSTJ(47).GE.1) THEN
36094         IF(KFLA(1).GE.1.AND.KFLA(1).LE.8.AND.KFLA(2).GE.1.AND.
36095      &  KFLA(2).LE.8) M3JC=1
36096         IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36097      &  KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)) M3JC=1
36098         IF((KFLA(1).EQ.11.OR.KFLA(1).EQ.13.OR.KFLA(1).EQ.15.OR.
36099      &  KFLA(1).EQ.17).AND.KFLA(2).EQ.KFLA(1)+1) M3JC=1
36100         IF((KFLA(1).EQ.12.OR.KFLA(1).EQ.14.OR.KFLA(1).EQ.16.OR.
36101      &  KFLA(1).EQ.18).AND.KFLA(2).EQ.KFLA(1)-1) M3JC=1
36102         IF(MSTJ(47).EQ.2.OR.MSTJ(47).EQ.4) M3JC=1
36103         M3JCM=0
36104         IF(M3JC.EQ.1.AND.MSTJ(47).GE.3.AND.KFLA(1).EQ.KFLA(2)) THEN
36105           M3JCM=1
36106           QME=(2D0*PMTH(1,KFLA(1))/PS(5))**2
36107         ENDIF
36108       ENDIF
36109
36110 C...Find if interference with initial state partons.
36111       MIIS=0
36112       IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2) MIIS=MSTJ(50)
36113       IF(MIIS.NE.0) THEN
36114         DO 180 I=1,2
36115           KCII(I)=0
36116           KCA=PYCOMP(KFLA(I))
36117           IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
36118           NIIS(I)=0
36119           IF(KCII(I).NE.0) THEN
36120             DO 170 J=1,2
36121               ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
36122               IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
36123      &        (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
36124                 NIIS(I)=NIIS(I)+1
36125                 IIIS(I,NIIS(I))=ICSI
36126               ENDIF
36127   170       CONTINUE
36128           ENDIF
36129   180   CONTINUE
36130         IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
36131       ENDIF
36132
36133 C...Boost interfering initial partons to rest frame
36134 C...and reconstruct their polar and azimuthal angles.
36135       IF(MIIS.NE.0) THEN
36136         DO 200 I=1,2
36137           DO 190 J=1,5
36138             K(N+I,J)=K(IPA(I),J)
36139             P(N+I,J)=P(IPA(I),J)
36140             V(N+I,J)=0D0
36141   190     CONTINUE
36142   200   CONTINUE
36143         DO 220 I=3,2+NIIS(1)
36144           DO 210 J=1,5
36145             K(N+I,J)=K(IIIS(1,I-2),J)
36146             P(N+I,J)=P(IIIS(1,I-2),J)
36147             V(N+I,J)=0D0
36148   210     CONTINUE
36149   220   CONTINUE
36150         DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36151           DO 230 J=1,5
36152             K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
36153             P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
36154             V(N+I,J)=0D0
36155   230     CONTINUE
36156   240   CONTINUE
36157         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
36158      &  -PS(2)/PS(4),-PS(3)/PS(4))
36159         PHI=PYANGL(P(N+1,1),P(N+1,2))
36160         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
36161         THE=PYANGL(P(N+1,3),P(N+1,1))
36162         CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
36163         DO 250 I=3,2+NIIS(1)
36164           THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
36165           PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
36166   250   CONTINUE
36167         DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
36168           THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
36169      &    SQRT(P(N+I,1)**2+P(N+I,2)**2))
36170           PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
36171   260   CONTINUE
36172       ENDIF
36173
36174 C...Define imagined single initiator of shower for parton system.
36175       NS=N
36176       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36177         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36178         IF(MSTU(21).GE.1) RETURN
36179       ENDIF
36180       IF(NPA.GE.2) THEN
36181         K(N+1,1)=11
36182         K(N+1,2)=21
36183         K(N+1,3)=0
36184         K(N+1,4)=0
36185         K(N+1,5)=0
36186         P(N+1,1)=0D0
36187         P(N+1,2)=0D0
36188         P(N+1,3)=0D0
36189         P(N+1,4)=PS(5)
36190         P(N+1,5)=PS(5)
36191         V(N+1,5)=PS(5)**2
36192         N=N+1
36193       ENDIF
36194
36195 C...Loop over partons that may branch.
36196       NEP=NPA
36197       IM=NS
36198       IF(NPA.EQ.1) IM=NS-1
36199   270 IM=IM+1
36200       IF(N.GT.NS) THEN
36201         IF(IM.GT.N) GOTO 510
36202         KFLM=IABS(K(IM,2))
36203         IF(KFLM.GT.40) GOTO 270
36204         IF(KSH(KFLM).EQ.0) GOTO 270
36205         IFLM=KFLM
36206         IF(KFLM.GE.6.AND.KFLM.LE.8) IFLM=37+KFLM+ISIGN(2,K(IM,2))
36207         IF(P(IM,5).LT.PMTH(2,IFLM)) GOTO 270
36208         IGM=K(IM,3)
36209       ELSE
36210         IGM=-1
36211       ENDIF
36212       IF(N+NEP.GT.MSTU(4)-MSTU(32)-5) THEN
36213         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36214         IF(MSTU(21).GE.1) RETURN
36215       ENDIF
36216
36217 C...Position of aunt (sister to branching parton).
36218 C...Origin and flavour of daughters.
36219       IAU=0
36220       IF(IGM.GT.0) THEN
36221         IF(K(IM-1,3).EQ.IGM) IAU=IM-1
36222         IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
36223       ENDIF
36224       IF(IGM.GE.0) THEN
36225         K(IM,4)=N+1
36226         DO 280 I=1,NEP
36227           K(N+I,3)=IM
36228   280   CONTINUE
36229       ELSE
36230         K(N+1,3)=IPA(1)
36231       ENDIF
36232       IF(IGM.LE.0) THEN
36233         DO 290 I=1,NEP
36234           K(N+I,2)=K(IPA(I),2)
36235   290   CONTINUE
36236       ELSEIF(KFLM.NE.21) THEN
36237         K(N+1,2)=K(IM,2)
36238         K(N+2,2)=K(IM,5)
36239       ELSEIF(K(IM,5).EQ.21) THEN
36240         K(N+1,2)=21
36241         K(N+2,2)=21
36242       ELSE
36243         K(N+1,2)=K(IM,5)
36244         K(N+2,2)=-K(IM,5)
36245       ENDIF
36246
36247 C...Reset flags on daughers and tries made.
36248       DO 300 IP=1,NEP
36249         K(N+IP,1)=3
36250         K(N+IP,4)=0
36251         K(N+IP,5)=0
36252         KFLD(IP)=IABS(K(N+IP,2))
36253         IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
36254         ITRY(IP)=0
36255         ISL(IP)=0
36256         ISI(IP)=0
36257         IF(KFLD(IP).LE.40) THEN
36258           IF(KSH(KFLD(IP)).EQ.1) ISI(IP)=1
36259         ENDIF
36260   300 CONTINUE
36261       ISLM=0
36262
36263 C...Maximum virtuality of daughters.
36264       IF(IGM.LE.0) THEN
36265         DO 310 I=1,NPA
36266           IF(NPA.GE.3) P(N+I,4)=(PS(4)*P(IPA(I),4)-PS(1)*P(IPA(I),1)-
36267      &    PS(2)*P(IPA(I),2)-PS(3)*P(IPA(I),3))/PS(5)
36268           P(N+I,5)=MIN(QMAX,PS(5))
36269           IF(NPA.GE.3) P(N+I,5)=MIN(P(N+I,5),P(N+I,4))
36270           IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
36271   310   CONTINUE
36272       ELSE
36273         IF(MSTJ(43).LE.2) PEM=V(IM,2)
36274         IF(MSTJ(43).GE.3) PEM=P(IM,4)
36275         P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
36276         P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
36277         IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
36278       ENDIF
36279       DO 320 I=1,NEP
36280         PMSD(I)=P(N+I,5)
36281         IF(ISI(I).EQ.1) THEN
36282           IFLD=KFLD(I)
36283           IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36284      &    ISIGN(2,K(N+I,2))
36285           IF(P(N+I,5).LE.PMTH(3,IFLD)) P(N+I,5)=PMTH(1,IFLD)
36286         ENDIF
36287         V(N+I,5)=P(N+I,5)**2
36288   320 CONTINUE
36289
36290 C...Choose one of the daughters for evolution.
36291   330 INUM=0
36292       IF(NEP.EQ.1) INUM=1
36293       DO 340 I=1,NEP
36294         IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
36295   340 CONTINUE
36296       DO 350 I=1,NEP
36297         IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
36298           IFLD=KFLD(I)
36299           IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36300      &    ISIGN(2,K(N+I,2))
36301           IF(P(N+I,5).GE.PMTH(2,IFLD)) INUM=I
36302         ENDIF
36303   350 CONTINUE
36304       IF(INUM.EQ.0) THEN
36305         RMAX=0D0
36306         DO 360 I=1,NEP
36307           IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQTH2) THEN
36308             RPM=P(N+I,5)/PMSD(I)
36309             IFLD=KFLD(I)
36310             IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36311      &      ISIGN(2,K(N+I,2))
36312             IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IFLD)) THEN
36313               RMAX=RPM
36314               INUM=I
36315             ENDIF
36316           ENDIF
36317   360   CONTINUE
36318       ENDIF
36319
36320 C...Store information on choice of evolving daughter.
36321       INUM=MAX(1,INUM)
36322       IEP(1)=N+INUM
36323       DO 370 I=2,NEP
36324         IEP(I)=IEP(I-1)+1
36325         IF(IEP(I).GT.N+NEP) IEP(I)=N+1
36326   370 CONTINUE
36327       DO 380 I=1,NEP
36328         KFL(I)=IABS(K(IEP(I),2))
36329   380 CONTINUE
36330       ITRY(INUM)=ITRY(INUM)+1
36331       IF(ITRY(INUM).GT.200) THEN
36332         CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
36333         IF(MSTU(21).GE.1) RETURN
36334       ENDIF
36335       Z=0.5D0
36336       IF(KFL(1).GT.40) GOTO 430
36337       IF(KSH(KFL(1)).EQ.0) GOTO 430
36338       IFL=KFL(1)
36339       IF(KFL(1).GE.6.AND.KFL(1).LE.8) IFL=37+KFL(1)+
36340      &ISIGN(2,K(IEP(1),2))
36341       IF(P(IEP(1),5).LT.PMTH(2,IFL)) GOTO 430
36342
36343 C...Select side for interference with initial state partons.
36344       IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
36345         III=IEP(1)-NS-1
36346         ISII(III)=0
36347         IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
36348           ISII(III)=1
36349         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
36350           IF(PYR(0).GT.0.5D0) ISII(III)=1
36351         ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
36352           ISII(III)=1
36353           IF(PYR(0).GT.0.5D0) ISII(III)=2
36354         ENDIF
36355       ENDIF
36356
36357 C...Calculate allowed z range.
36358       IF(NEP.EQ.1) THEN
36359         PMED=PS(4)
36360       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36361         PMED=P(IM,5)
36362       ELSE
36363         IF(INUM.EQ.1) PMED=V(IM,1)*PEM
36364         IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
36365       ENDIF
36366       IF(MOD(MSTJ(43),2).EQ.1) THEN
36367         ZC=PMTH(2,21)/PMED
36368         ZCE=PMTH(2,22)/PMED
36369       ELSE
36370         ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
36371         IF(ZC.LT.1D-4) ZC=(PMTH(2,21)/PMED)**2
36372         ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,22)/PMED)**2)))
36373         IF(ZCE.LT.1D-4) ZCE=(PMTH(2,22)/PMED)**2
36374       ENDIF
36375       ZC=MIN(ZC,0.491D0)
36376       ZCE=MIN(ZCE,0.491D0)
36377       IF((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
36378      &MIN(ZC,ZCE).GT.0.49D0)) THEN
36379         P(IEP(1),5)=PMTH(1,IFL)
36380         V(IEP(1),5)=P(IEP(1),5)**2
36381         GOTO 430
36382       ENDIF
36383
36384 C...Integral of Altarelli-Parisi z kernel for QCD.
36385       IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
36386         FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*(0.5D0-ZC)
36387       ELSEIF(MSTJ(49).EQ.0) THEN
36388         FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
36389
36390 C...Integral of Altarelli-Parisi z kernel for scalar gluon.
36391       ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
36392         FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
36393       ELSEIF(MSTJ(49).EQ.1) THEN
36394         FBR=(1D0-2D0*ZC)/3D0
36395         IF(IGM.EQ.0.AND.M3JC.EQ.1) FBR=4D0*FBR
36396
36397 C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
36398       ELSEIF(KFL(1).EQ.21) THEN
36399         FBR=6D0*MSTJ(45)*(0.5D0-ZC)
36400       ELSE
36401         FBR=2D0*LOG((1D0-ZC)/ZC)
36402       ENDIF
36403
36404 C...Reset QCD probability for lepton.
36405       IF(KFL(1).GE.11.AND.KFL(1).LE.18) FBR=0D0
36406
36407 C...Integral of Altarelli-Parisi kernel for photon emission.
36408       IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36409         FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
36410         IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
36411       ENDIF
36412
36413 C...Inner veto algorithm starts. Find maximum mass for evolution.
36414   390 PMS=V(IEP(1),5)
36415       IF(IGM.GE.0) THEN
36416         PM2=0D0
36417         DO 400 I=2,NEP
36418           PM=P(IEP(I),5)
36419           IF(KFL(I).LE.40) THEN
36420             IFLI=KFL(I)
36421             IF(KFL(I).GE.6.AND.KFL(I).LE.8) IFLI=37+KFL(I)+
36422      &      ISIGN(2,K(IEP(I),2))
36423             IF(KSH(KFL(I)).EQ.1) PM=PMTH(2,IFLI)
36424           ENDIF
36425           PM2=PM2+PM
36426   400   CONTINUE
36427         PMS=MIN(PMS,(P(IM,5)-PM2)**2)
36428       ENDIF
36429
36430 C...Select mass for daughter in QCD evolution.
36431       B0=27D0/6D0
36432       DO 410 IFF=4,MSTJ(45)
36433         IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
36434   410 CONTINUE
36435       IF(FBR.LT.1D-3) THEN
36436         PMSQCD=0D0
36437       ELSEIF(MSTJ(44).LE.0) THEN
36438         PMSQCD=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
36439       ELSEIF(MSTJ(44).EQ.1) THEN
36440         PMSQCD=4D0*ALAMS*(0.25D0*PMS/ALAMS)**(PYR(0)**(B0/FBR))
36441       ELSE
36442         PMSQCD=PMS*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
36443       ENDIF
36444       IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IFL)**2) PMSQCD=PMTH(2,IFL)**2
36445       V(IEP(1),5)=PMSQCD
36446       MCE=1
36447
36448 C...Select mass for daughter in QED evolution.
36449       IF(MSTJ(41).GE.2.AND.KFL(1).GE.1.AND.KFL(1).LE.18) THEN
36450         PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
36451         IF(ZCE.GT.0.49D0.OR.PMSQED.LE.PMTH(5,IFL)**2) PMSQED=
36452      &  PMTH(2,IFL)**2
36453         IF(PMSQED.GT.PMSQCD) THEN
36454           V(IEP(1),5)=PMSQED
36455           MCE=2
36456         ENDIF
36457       ENDIF
36458
36459 C...Check whether daughter mass below cutoff.
36460       P(IEP(1),5)=SQRT(V(IEP(1),5))
36461       IF(P(IEP(1),5).LE.PMTH(3,IFL)) THEN
36462         P(IEP(1),5)=PMTH(1,IFL)
36463         V(IEP(1),5)=P(IEP(1),5)**2
36464         GOTO 430
36465       ENDIF
36466
36467 C...Select z value of branching: q -> qgamma.
36468       IF(MCE.EQ.2) THEN
36469         Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
36470         IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36471         K(IEP(1),5)=22
36472
36473 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
36474       ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
36475         Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36476         IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390
36477         K(IEP(1),5)=21
36478       ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN
36479         Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
36480         IF(PYR(0).GT.0.5D0) Z=1D0-Z
36481         IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390
36482         K(IEP(1),5)=21
36483       ELSEIF(MSTJ(49).NE.1) THEN
36484         Z=ZC+(1D0-2D0*ZC)*PYR(0)
36485         IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390
36486         KFLB=1+INT(MSTJ(45)*PYR(0))
36487         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36488         IF(PMQ.GE.1D0) GOTO 390
36489         PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
36490         IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.
36491      &  PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390
36492         K(IEP(1),5)=KFLB
36493
36494 C...Ditto for scalar gluon model.
36495       ELSEIF(KFL(1).NE.21) THEN
36496         Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
36497         K(IEP(1),5)=21
36498       ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
36499         Z=ZC+(1D0-2D0*ZC)*PYR(0)
36500         K(IEP(1),5)=21
36501       ELSE
36502         Z=ZC+(1D0-2D0*ZC)*PYR(0)
36503         KFLB=1+INT(MSTJ(45)*PYR(0))
36504         PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
36505         IF(PMQ.GE.1D0) GOTO 390
36506         K(IEP(1),5)=KFLB
36507       ENDIF
36508       IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN
36509         IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390
36510         IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390
36511       ENDIF
36512
36513 C...Check if z consistent with chosen m.
36514       IF(KFL(1).EQ.21) THEN
36515         KFLGD1=IABS(K(IEP(1),5))
36516         KFLGD2=KFLGD1
36517       ELSE
36518         KFLGD1=KFL(1)
36519         KFLGD2=IABS(K(IEP(1),5))
36520       ENDIF
36521       IF(NEP.EQ.1) THEN
36522         PED=PS(4)
36523       ELSEIF(NEP.GE.3) THEN
36524         PED=P(IEP(1),4)
36525       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36526         PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
36527       ELSE
36528         IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
36529         IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
36530       ENDIF
36531       IF(MOD(MSTJ(43),2).EQ.1) THEN
36532         IFLGD1=KFLGD1
36533         IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL
36534         PMQTH3=0.5D0*PARJ(82)
36535         IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36536         PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5)
36537         PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5)
36538         ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36539      &  4D0*PMQ1*PMQ2)))
36540         ZH=1D0+PMQ1-PMQ2
36541       ELSE
36542         ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
36543         ZH=1D0
36544       ENDIF
36545       ZL=0.5D0*(ZH-ZD)
36546       ZU=0.5D0*(ZH+ZD)
36547       IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
36548       IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
36549      &(1D0-ZU)))
36550       IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36551
36552 C...Width suppression for q -> q + g.
36553       IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN
36554         IF(IGM.EQ.0) THEN
36555           EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
36556         ELSE
36557           EGLU=PMED*(1D0-Z)
36558         ENDIF
36559         CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
36560         IF(MSTJ(40).EQ.1) THEN
36561           IF(CHI.LT.PYR(0)) GOTO 390
36562         ELSEIF(MSTJ(40).EQ.2) THEN
36563           IF(1D0-CHI.LT.PYR(0)) GOTO 390
36564         ENDIF
36565       ENDIF
36566
36567 C...Three-jet matrix element correction.
36568       IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN
36569         X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
36570         X2=1D0-V(IEP(1),5)/V(NS+1,5)
36571         X3=(1D0-X1)+(1D0-X2)
36572         IF(MCE.EQ.2) THEN
36573           KI1=K(IPA(INUM),2)
36574           KI2=K(IPA(3-INUM),2)
36575           QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0
36576           QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0
36577           WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
36578      &    QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
36579           WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
36580         ELSEIF(MSTJ(49).NE.1) THEN
36581           WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
36582      &    (1D0-X2)/X3*(X2/(2D0-X1))**2
36583           WME=X1**2+X2**2
36584           IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2-
36585      &    (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+
36586      &    (1D0-X1)/MAX(1D-7,1D0-X2))
36587         ELSE
36588           WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
36589           WME=X3**2
36590           IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
36591      &    PARJ(171)
36592         ENDIF
36593         IF(WME.LT.PYR(0)*WSHOW) GOTO 390
36594
36595 C...Impose angular ordering by rejection of nonordered emission.
36596       ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN
36597         MAOM=1
36598         ZM=V(IM,1)
36599         IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1)
36600         THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5)
36601         IAOM=IM
36602   420   IF(K(IAOM,5).EQ.22) THEN
36603           IAOM=K(IAOM,3)
36604           IF(K(IAOM,3).LE.NS) MAOM=0
36605           IF(MAOM.EQ.1) GOTO 420
36606         ENDIF
36607         IF(MAOM.EQ.1) THEN
36608           THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
36609           IF(THE2ID.LT.THE2IM) GOTO 390
36610         ENDIF
36611       ENDIF
36612
36613 C...Impose user-defined maximum angle at first branching.
36614       IF(MSTJ(48).EQ.1) THEN
36615         IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
36616           THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
36617           IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36618         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
36619           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36620           IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390
36621         ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
36622           THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
36623           IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390
36624         ENDIF
36625       ENDIF
36626
36627 C...Impose angular constraint in first branching from interference
36628 C...with initial state partons.
36629       IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
36630         THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
36631         IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
36632           IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390
36633         ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
36634           IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390
36635         ENDIF
36636       ENDIF
36637
36638 C...End of inner veto algorithm. Check if only one leg evolved so far.
36639   430 V(IEP(1),1)=Z
36640       ISL(1)=0
36641       ISL(2)=0
36642       IF(NEP.EQ.1) GOTO 460
36643       IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330
36644       DO 440 I=1,NEP
36645         IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN
36646           IF(KSH(KFLD(I)).EQ.1) THEN
36647             IFLD=KFLD(I)
36648             IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+
36649      &      ISIGN(2,K(N+I,2))
36650             IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330
36651           ENDIF
36652         ENDIF
36653   440 CONTINUE
36654
36655 C...Check if chosen multiplet m1,m2,z1,z2 is physical.
36656       IF(NEP.EQ.3) THEN
36657         PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5))
36658         PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5))
36659         PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5))
36660         PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S-
36661      &  PA1S**2-PA2S**2-PA3S**2)/PA1S
36662         IF(PTS.LE.0D0) GOTO 330
36663       ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
36664         DO 450 I1=N+1,N+2
36665           KFLDA=IABS(K(I1,2))
36666           IF(KFLDA.GT.40) GOTO 450
36667           IF(KSH(KFLDA).EQ.0) GOTO 450
36668           IFLDA=KFLDA
36669           IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+
36670      &    ISIGN(2,K(I1,2))
36671           IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450
36672           IF(KFLDA.EQ.21) THEN
36673             KFLGD1=IABS(K(I1,5))
36674             KFLGD2=KFLGD1
36675           ELSE
36676             KFLGD1=KFLDA
36677             KFLGD2=IABS(K(I1,5))
36678           ENDIF
36679           I2=2*N+3-I1
36680           IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
36681             PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
36682           ELSE
36683             IF(I1.EQ.N+1) ZM=V(IM,1)
36684             IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
36685             PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
36686      &      4D0*V(N+1,5)*V(N+2,5))
36687             PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5)
36688           ENDIF
36689           IF(MOD(MSTJ(43),2).EQ.1) THEN
36690             PMQTH3=0.5D0*PARJ(82)
36691             IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
36692             IFLGD1=KFLGD1
36693             IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA
36694             PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5)
36695             PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5)
36696             ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
36697      &      4D0*PMQ1*PMQ2)))
36698             ZH=1D0+PMQ1-PMQ2
36699           ELSE
36700             ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
36701             ZH=1D0
36702           ENDIF
36703           ZL=0.5D0*(ZH-ZD)
36704           ZU=0.5D0*(ZH+ZD)
36705           IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1
36706           IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1
36707           IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
36708      &    ZL*(1D0-ZU)))
36709           IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
36710   450   CONTINUE
36711         IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
36712           ISL(3-ISLM)=0
36713           ISLM=3-ISLM
36714         ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
36715           ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
36716           ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
36717           IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
36718           IF(ISL(1).EQ.1) ISL(2)=0
36719           IF(ISL(1).EQ.0) ISLM=1
36720           IF(ISL(2).EQ.0) ISLM=2
36721         ENDIF
36722         IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330
36723       ENDIF
36724       IFLD1=KFLD(1)
36725       IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+
36726      &ISIGN(2,K(N+1,2))
36727       IFLD2=KFLD(2)
36728       IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+
36729      &ISIGN(2,K(N+2,2))
36730       IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
36731      &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN
36732         PMQ1=V(N+1,5)/V(IM,5)
36733         PMQ2=V(N+2,5)/V(IM,5)
36734         ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
36735      &  4D0*PMQ1*PMQ2)))
36736         ZH=1D0+PMQ1-PMQ2
36737         ZL=0.5D0*(ZH-ZD)
36738         ZU=0.5D0*(ZH+ZD)
36739         IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330
36740       ENDIF
36741
36742 C...Accepted branch. Construct four-momentum for initial partons.
36743   460 MAZIP=0
36744       MAZIC=0
36745       IF(NEP.EQ.1) THEN
36746         P(N+1,1)=0D0
36747         P(N+1,2)=0D0
36748         P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
36749      &  P(N+1,5))))
36750         P(N+1,4)=P(IPA(1),4)
36751         V(N+1,2)=P(N+1,4)
36752       ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
36753         PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
36754         P(N+1,1)=0D0
36755         P(N+1,2)=0D0
36756         P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
36757         P(N+1,4)=PED1
36758         P(N+2,1)=0D0
36759         P(N+2,2)=0D0
36760         P(N+2,3)=-P(N+1,3)
36761         P(N+2,4)=P(IM,5)-PED1
36762         V(N+1,2)=P(N+1,4)
36763         V(N+2,2)=P(N+2,4)
36764       ELSEIF(NEP.EQ.3) THEN
36765         P(N+1,1)=0D0
36766         P(N+1,2)=0D0
36767         P(N+1,3)=SQRT(MAX(0D0,PA1S))
36768         P(N+2,1)=SQRT(PTS)
36769         P(N+2,2)=0D0
36770         P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3)
36771         P(N+3,1)=-P(N+2,1)
36772         P(N+3,2)=0D0
36773         P(N+3,3)=-(P(N+1,3)+P(N+2,3))
36774         V(N+1,2)=P(N+1,4)
36775         V(N+2,2)=P(N+2,4)
36776         V(N+3,2)=P(N+3,4)
36777
36778 C...Construct transverse momentum for ordinary branching in shower.
36779       ELSE
36780         ZM=V(IM,1)
36781         PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
36782         PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
36783         IF(PZM.LE.0D0) THEN
36784           PTS=0D0
36785         ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
36786           PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
36787      &    ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
36788         ELSE
36789           PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
36790         ENDIF
36791         PT=SQRT(MAX(0D0,PTS))
36792
36793 C...Find coefficient of azimuthal asymmetry due to gluon polarization.
36794         HAZIP=0D0
36795         IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
36796      &  .AND.IAU.NE.0) THEN
36797           IF(K(IGM,3).NE.0) MAZIP=1
36798           ZAU=V(IGM,1)
36799           IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
36800           IF(MAZIP.EQ.0) ZAU=0D0
36801           IF(K(IGM,2).NE.21) THEN
36802             HAZIP=2D0*ZAU/(1D0+ZAU**2)
36803           ELSE
36804             HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
36805           ENDIF
36806           IF(K(N+1,2).NE.21) THEN
36807             HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
36808           ELSE
36809             HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
36810           ENDIF
36811         ENDIF
36812
36813 C...Find coefficient of azimuthal asymmetry due to soft gluon
36814 C...interference.
36815         HAZIC=0D0
36816         IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
36817      &  K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
36818           IF(K(IGM,3).NE.0) MAZIC=N+1
36819           IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
36820           IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36821      &    ZM.GT.0.5D0) MAZIC=N+2
36822           IF(K(IAU,2).EQ.22) MAZIC=0
36823           ZS=ZM
36824           IF(MAZIC.EQ.N+2) ZS=1D0-ZM
36825           ZGM=V(IGM,1)
36826           IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
36827           IF(MAZIC.EQ.0) ZGM=1D0
36828           IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
36829      &    SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
36830           HAZIC=MIN(0.95D0,HAZIC)
36831         ENDIF
36832       ENDIF
36833
36834 C...Construct kinematics for ordinary branching in shower.
36835   470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
36836         IF(MOD(MSTJ(43),2).EQ.1) THEN
36837           P(N+1,4)=PEM*V(IM,1)
36838         ELSE
36839           P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
36840      &    SQRT(PMLS)*ZM)/V(IM,5)
36841         ENDIF
36842         PHI=PARU(2)*PYR(0)
36843         P(N+1,1)=PT*COS(PHI)
36844         P(N+1,2)=PT*SIN(PHI)
36845         IF(PZM.GT.0D0) THEN
36846           P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
36847      &    2D0*PEM*P(N+1,4))/PZM
36848         ELSE
36849           P(N+1,3)=0D0
36850         ENDIF
36851         P(N+2,1)=-P(N+1,1)
36852         P(N+2,2)=-P(N+1,2)
36853         P(N+2,3)=PZM-P(N+1,3)
36854         P(N+2,4)=PEM-P(N+1,4)
36855         IF(MSTJ(43).LE.2) THEN
36856           V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
36857           V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
36858         ENDIF
36859       ENDIF
36860
36861 C...Rotate and boost daughters.
36862       IF(IGM.GT.0) THEN
36863         IF(MSTJ(43).LE.2) THEN
36864           BEX=P(IGM,1)/P(IGM,4)
36865           BEY=P(IGM,2)/P(IGM,4)
36866           BEZ=P(IGM,3)/P(IGM,4)
36867           GA=P(IGM,4)/P(IGM,5)
36868           GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
36869      &    P(IM,4))
36870         ELSE
36871           BEX=0D0
36872           BEY=0D0
36873           BEZ=0D0
36874           GA=1D0
36875           GABEP=0D0
36876         ENDIF
36877         THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+
36878      &  (P(IM,2)+GABEP*BEY)**2))
36879         PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
36880         DO 480 I=N+1,N+2
36881           DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
36882      &    SIN(THE)*COS(PHI)*P(I,3)
36883           DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
36884      &    SIN(THE)*SIN(PHI)*P(I,3)
36885           DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
36886           DP(4)=P(I,4)
36887           DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
36888           DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
36889           P(I,1)=DP(1)+DGABP*BEX
36890           P(I,2)=DP(2)+DGABP*BEY
36891           P(I,3)=DP(3)+DGABP*BEZ
36892           P(I,4)=GA*(DP(4)+DBP)
36893   480   CONTINUE
36894       ENDIF
36895
36896 C...Weight with azimuthal distribution, if required.
36897       IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
36898         DO 490 J=1,3
36899           DPT(1,J)=P(IM,J)
36900           DPT(2,J)=P(IAU,J)
36901           DPT(3,J)=P(N+1,J)
36902   490   CONTINUE
36903         DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
36904         DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
36905         DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
36906         DO 500 J=1,3
36907           DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM
36908           DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM
36909   500   CONTINUE
36910         DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
36911         DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
36912         IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
36913           CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
36914      &    DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
36915           IF(MAZIP.NE.0) THEN
36916             IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
36917      &      GOTO 470
36918           ENDIF
36919           IF(MAZIC.NE.0) THEN
36920             IF(MAZIC.EQ.N+2) CAD=-CAD
36921             IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
36922      &      .LT.PYR(0)) GOTO 470
36923           ENDIF
36924         ENDIF
36925       ENDIF
36926
36927 C...Azimuthal anisotropy due to interference with initial state partons.
36928       IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
36929      &K(N+2,2).EQ.21)) THEN
36930         III=IM-NS-1
36931         IF(ISII(III).GE.1) THEN
36932           IAZIID=N+1
36933           IF(K(N+1,2).NE.21) IAZIID=N+2
36934           IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
36935      &    P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
36936           THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
36937           IF(III.EQ.2) THEIID=PARU(1)-THEIID
36938           PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
36939           HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
36940           CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
36941           PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
36942           IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
36943           IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
36944      &    .LT.PYR(0)) GOTO 470
36945         ENDIF
36946       ENDIF
36947
36948 C...Continue loop over partons that may branch, until none left.
36949       IF(IGM.GE.0) K(IM,1)=14
36950       N=N+NEP
36951       NEP=2
36952       IF(N.GT.MSTU(4)-MSTU(32)-5) THEN
36953         CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
36954         IF(MSTU(21).GE.1) N=NS
36955         IF(MSTU(21).GE.1) RETURN
36956       ENDIF
36957       GOTO 270
36958
36959 C...Set information on imagined shower initiator.
36960   510 IF(NPA.GE.2) THEN
36961         K(NS+1,1)=11
36962         K(NS+1,2)=94
36963         K(NS+1,3)=IP1
36964         IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
36965         K(NS+1,4)=NS+2
36966         K(NS+1,5)=NS+1+NPA
36967         IIM=1
36968       ELSE
36969         IIM=0
36970       ENDIF
36971
36972 C...Reconstruct string drawing information.
36973       DO 520 I=NS+1+IIM,N
36974         IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
36975           K(I,1)=1
36976         ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
36977      &    IABS(K(I,2)).LE.18) THEN
36978           K(I,1)=1
36979         ELSEIF(K(I,1).LE.10) THEN
36980           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
36981           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
36982         ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
36983           ID1=MOD(K(I,4),MSTU(5))
36984           IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1
36985           ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
36986           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36987           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
36988           K(ID1,4)=K(ID1,4)+MSTU(5)*I
36989           K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
36990           K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
36991           K(ID2,5)=K(ID2,5)+MSTU(5)*I
36992         ELSE
36993           ID1=MOD(K(I,4),MSTU(5))
36994           ID2=ID1+1
36995           K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
36996           K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
36997           IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN
36998             K(ID1,4)=K(ID1,4)+MSTU(5)*I
36999             K(ID1,5)=K(ID1,5)+MSTU(5)*I
37000           ELSE
37001             K(ID1,4)=0
37002             K(ID1,5)=0
37003           ENDIF
37004           K(ID2,4)=0
37005           K(ID2,5)=0
37006         ENDIF
37007   520 CONTINUE
37008
37009 C...Transformation from CM frame.
37010       IF(NPA.GE.2) THEN
37011         BEX=PS(1)/PS(4)
37012         BEY=PS(2)/PS(4)
37013         BEZ=PS(3)/PS(4)
37014         GA=PS(4)/PS(5)
37015         GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
37016      &  /(1D0+GA)-P(IPA(1),4))
37017       ELSE
37018         BEX=0D0
37019         BEY=0D0
37020         BEZ=0D0
37021         GABEP=0D0
37022       ENDIF
37023       THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
37024      &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
37025       PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
37026       IF(NPA.EQ.3) THEN
37027         CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)*
37028      &  SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP*
37029      &  BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+
37030      &  GABEP*BEY))
37031         MSTU(33)=1
37032         CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0)
37033       ENDIF
37034       MSTU(33)=1
37035       CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
37036
37037 C...Decay vertex of shower.
37038       DO 540 I=NS+1,N
37039         DO 530 J=1,5
37040           V(I,J)=V(IP1,J)
37041   530   CONTINUE
37042   540 CONTINUE
37043
37044 C...Delete trivial shower, else connect initiators.
37045       IF(N.EQ.NS+NPA+IIM) THEN
37046         N=NS
37047       ELSE
37048         DO 550 IP=1,NPA
37049           K(IPA(IP),1)=14
37050           K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
37051           K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
37052           K(NS+IIM+IP,3)=IPA(IP)
37053           IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
37054           IF(K(NS+IIM+IP,1).NE.1) THEN
37055             K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
37056             K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
37057           ENDIF
37058   550   CONTINUE
37059       ENDIF
37060
37061       RETURN
37062       END
37063
37064 C*********************************************************************
37065
37066 *$ CREATE PYBOEI.FOR
37067 *COPY PYBOEI
37068 C...PYBOEI
37069 C...Modifies an event so as to approximately take into account
37070 C...Bose-Einstein effects according to a simple phenomenological
37071 C...parametrization.
37072
37073       SUBROUTINE PYBOEI(NSAV)
37074
37075 C...Double precision and integer declarations.
37076       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37077       INTEGER PYK,PYCHGE,PYCOMP
37078 C...Commonblocks.
37079       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37080       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37081       SAVE /PYJETS/,/PYDAT1/
37082 C...Local arrays and data.
37083       DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100)
37084       DATA KFBE/211,-211,111,321,-321,130,310,221,331/
37085
37086 C...Boost event to overall CM frame. Calculate CM energy.
37087       IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
37088       DO 100 J=1,4
37089         DPS(J)=0D0
37090   100 CONTINUE
37091       DO 120 I=1,N
37092         KFA=IABS(K(I,2))
37093         IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
37094      &  .AND.K(I,3).GT.0) THEN
37095           KFMA=IABS(K(K(I,3),2))
37096           IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
37097         ENDIF
37098         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
37099         DO 110 J=1,4
37100           DPS(J)=DPS(J)+P(I,J)
37101   110   CONTINUE
37102   120 CONTINUE
37103       CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
37104      &-DPS(3)/DPS(4))
37105       PECM=0D0
37106       DO 130 I=1,N
37107         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
37108   130 CONTINUE
37109
37110 C...Reserve copy of particles by species at end of record.
37111       NBE(0)=N+MSTU(3)
37112       DO 160 IBE=1,MIN(9,MSTJ(52))
37113         NBE(IBE)=NBE(IBE-1)
37114         DO 150 I=NSAV+1,N
37115           IF(K(I,2).NE.KFBE(IBE)) GOTO 150
37116           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
37117           IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
37118             CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
37119             RETURN
37120           ENDIF
37121           NBE(IBE)=NBE(IBE)+1
37122           K(NBE(IBE),1)=I
37123           DO 140 J=1,3
37124             P(NBE(IBE),J)=0D0
37125   140     CONTINUE
37126   150   CONTINUE
37127   160 CONTINUE
37128       IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280
37129
37130 C...Tabulate integral for subsequent momentum shift.
37131       DO 220 IBE=1,MIN(9,MSTJ(52))
37132         IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180
37133         IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
37134      &  .LE.1) GOTO 180
37135         IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
37136      &  NBE(7)-NBE(6)).LE.1) GOTO 180
37137         IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180
37138         IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
37139         IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
37140         IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
37141         IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
37142         QDEL=0.1D0*MIN(PMHQ,PARJ(93))
37143         IF(MSTJ(51).EQ.1) THEN
37144           NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
37145           BEEX=EXP(0.5D0*QDEL/PARJ(93))
37146           BERT=EXP(-QDEL/PARJ(93))
37147         ELSE
37148           NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
37149         ENDIF
37150         DO 170 IBIN=1,NBIN
37151           QBIN=QDEL*(IBIN-0.5D0)
37152           BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
37153           IF(MSTJ(51).EQ.1) THEN
37154             BEEX=BEEX*BERT
37155             BEI(IBIN)=BEI(IBIN)*BEEX
37156           ELSE
37157             BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
37158           ENDIF
37159           IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
37160   170   CONTINUE
37161
37162 C...Loop through particle pairs and find old relative momentum.
37163   180   DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1
37164           I1=K(I1M,1)
37165           DO 200 I2M=I1M+1,NBE(IBE)
37166             I2=K(I2M,1)
37167             Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
37168      &      (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
37169      &      (P(I1,5)+P(I2,5))**2)
37170             QOLD=SQRT(Q2OLD)
37171
37172 C...Calculate new relative momentum.
37173             IF(QOLD.LT.1D-3*QDEL) THEN
37174               GOTO 200
37175             ELSEIF(QOLD.LE.QDEL) THEN
37176               QMOV=QOLD/3D0
37177             ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
37178               RBIN=QOLD/QDEL
37179               IBIN=RBIN
37180               RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
37181               QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
37182      &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
37183             ELSE
37184               QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
37185             ENDIF
37186             Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
37187
37188 C...Calculate and save shift to be performed on three-momenta.
37189             HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW)
37190             HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2
37191             HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2)))
37192             DO 190 J=1,3
37193               PD=HA*(P(I2,J)-P(I1,J))
37194               P(I1M,J)=P(I1M,J)+PD
37195               P(I2M,J)=P(I2M,J)-PD
37196   190       CONTINUE
37197   200     CONTINUE
37198   210   CONTINUE
37199   220 CONTINUE
37200
37201 C...Shift momenta and recalculate energies.
37202       DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52)))
37203         I=K(IM,1)
37204         DO 230 J=1,3
37205           P(I,J)=P(I,J)+P(IM,J)
37206   230   CONTINUE
37207         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37208   240 CONTINUE
37209
37210 C...Rescale all momenta for energy conservation.
37211       PES=0D0
37212       PQS=0D0
37213       DO 250 I=1,N
37214         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250
37215         PES=PES+P(I,4)
37216         PQS=PQS+P(I,5)**2/P(I,4)
37217   250 CONTINUE
37218       FAC=(PECM-PQS)/(PES-PQS)
37219       DO 270 I=1,N
37220         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270
37221         DO 260 J=1,3
37222           P(I,J)=FAC*P(I,J)
37223   260   CONTINUE
37224         P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
37225   270 CONTINUE
37226
37227 C...Boost back to correct reference frame.
37228   280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
37229       DO 290 I=1,N
37230         IF(K(I,1).LT.0) K(I,1)=-K(I,1)
37231   290 CONTINUE
37232
37233       RETURN
37234       END
37235
37236 C*********************************************************************
37237
37238 *$ CREATE PYMASS.FOR
37239 *COPY PYMASS
37240 C...PYMASS
37241 C...Gives the mass of a particle/parton.
37242
37243       FUNCTION PYMASS(KF)
37244
37245 C...Double precision and integer declarations.
37246       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37247       INTEGER PYK,PYCHGE,PYCOMP
37248 C...Commonblocks.
37249       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37250       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37251       SAVE /PYDAT1/,/PYDAT2/
37252
37253 C...Reset variables. Compressed code. Special case for popcorn diquarks.
37254       PYMASS=0D0
37255       KFA=IABS(KF)
37256       KC=PYCOMP(KF)
37257       IF(KC.EQ.0) THEN
37258         MSTJ(93)=0
37259         RETURN
37260       ENDIF
37261
37262 C...Guarantee use of constituent masses for internal checks.
37263       IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
37264      &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
37265         PARF(106)=PMAS(6,1)
37266         PARF(107)=PMAS(7,1)
37267         PARF(108)=PMAS(8,1)
37268         IF(KFA.LE.10) THEN
37269           PYMASS=PARF(100+KFA)
37270           IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
37271         ELSEIF(MSTJ(93).EQ.1) THEN
37272           PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
37273         ELSE
37274           PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
37275         ENDIF
37276
37277 C...Other masses can be read directly off table.
37278       ELSE
37279         PYMASS=PMAS(KC,1)
37280       ENDIF
37281
37282 C...Optional mass broadening according to truncated Breit-Wigner
37283 C...(either in m or in m^2).
37284       IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
37285         IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
37286           PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
37287      &    ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
37288         ELSE
37289           PM0=PYMASS
37290           PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
37291      &    (PM0*PMAS(KC,2)))
37292           PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
37293           PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
37294      &    (PMUPP-PMLOW)*PYR(0))))
37295         ENDIF
37296       ENDIF
37297       MSTJ(93)=0
37298
37299       RETURN
37300       END
37301
37302 C*********************************************************************
37303
37304 *$ CREATE PYNAME.FOR
37305 *COPY PYNAME
37306 C...PYNAME
37307 C...Gives the particle/parton name as a character string.
37308
37309       SUBROUTINE PYNAME(KF,CHAU)
37310
37311 C...Double precision and integer declarations.
37312       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37313       INTEGER PYK,PYCHGE,PYCOMP
37314 C...Commonblocks.
37315       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37316       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37317       COMMON/PYDAT4/CHAF(500,2)
37318       CHARACTER CHAF*16
37319       SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
37320 C...Local character variable.
37321       CHARACTER CHAU*16
37322
37323 C...Read out code with distinction particle/antiparticle.
37324       CHAU=' '
37325       KC=PYCOMP(KF)
37326       IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
37327
37328
37329       RETURN
37330       END
37331
37332 C*********************************************************************
37333
37334 *$ CREATE PYCHGE.FOR
37335 *COPY PYCHGE
37336 C...PYCHGE
37337 C...Gives three times the charge for a particle/parton.
37338
37339       FUNCTION PYCHGE(KF)
37340
37341 C...Double precision and integer declarations.
37342       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37343       INTEGER PYK,PYCHGE,PYCOMP
37344 C...Commonblocks.
37345       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37346       SAVE /PYDAT2/
37347
37348 C...Read out charge and change sign for antiparticle.
37349       PYCHGE=0
37350       KC=PYCOMP(KF)
37351       IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
37352
37353       RETURN
37354       END
37355
37356 C*********************************************************************
37357
37358 *$ CREATE PYCOMP.FOR
37359 *COPY PYCOMP
37360 C...PYCOMP
37361 C...Compress the standard KF codes for use in mass and decay arrays;
37362 C...also checks whether a given code actually is defined.
37363
37364       FUNCTION PYCOMP(KF)
37365
37366 C...Double precision and integer declarations.
37367       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37368       INTEGER PYK,PYCHGE,PYCOMP
37369 C...Commonblocks.
37370       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37371       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37372       SAVE /PYDAT1/,/PYDAT2/
37373 C...Local arrays and saved data.
37374       DIMENSION KFORD(100:500),KCORD(101:500)
37375       SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
37376
37377 C...Whenever necessary reorder codes for faster search.
37378       IF(MSTU(20).EQ.0) THEN
37379         NFORD=100
37380         KFORD(100)=0
37381         DO 120 I=101,500
37382           KFA=KCHG(I,4)
37383           IF(KFA.LE.100) GOTO 120
37384           NFORD=NFORD+1
37385           DO 100 I1=NFORD-1,0,-1
37386             IF(KFA.GE.KFORD(I1)) GOTO 110
37387             KFORD(I1+1)=KFORD(I1)
37388             KCORD(I1+1)=KCORD(I1)
37389   100     CONTINUE
37390   110     KFORD(I1+1)=KFA
37391           KCORD(I1+1)=I
37392   120   CONTINUE
37393         MSTU(20)=1
37394         KFLAST=0
37395         KCLAST=0
37396       ENDIF
37397
37398 C...Fast action if same code as in latest call.
37399       IF(KF.EQ.KFLAST) THEN
37400         PYCOMP=KCLAST
37401         RETURN
37402       ENDIF
37403
37404 C...Starting values. Remove internal diquark flags.
37405       PYCOMP=0
37406       KFA=IABS(KF)
37407       IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
37408      &     .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
37409
37410 C...Simple cases: direct translation.
37411       IF(KFA.GT.KFORD(NFORD)) THEN
37412       ELSEIF(KFA.LE.100) THEN
37413         PYCOMP=KFA
37414
37415 C...Else binary search.
37416       ELSE
37417         IMIN=100
37418         IMAX=NFORD+1
37419   130   IAVG=(IMIN+IMAX)/2
37420         IF(KFORD(IAVG).GT.KFA) THEN
37421           IMAX=IAVG
37422           IF(IMAX.GT.IMIN+1) GOTO 130
37423         ELSEIF(KFORD(IAVG).LT.KFA) THEN
37424           IMIN=IAVG
37425           IF(IMAX.GT.IMIN+1) GOTO 130
37426         ELSE
37427           PYCOMP=KCORD(IAVG)
37428         ENDIF
37429       ENDIF
37430
37431 C...Check if antiparticle allowed.
37432       IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
37433         IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
37434       ENDIF
37435
37436 C...Save codes for possible future fast action.
37437       KFLAST=KF
37438       KCLAST=PYCOMP
37439
37440       RETURN
37441       END
37442
37443 C*********************************************************************
37444
37445 *$ CREATE PYERRM.FOR
37446 *COPY PYERRM
37447 C...PYERRM
37448 C...Informs user of errors in program execution.
37449
37450       SUBROUTINE PYERRM(MERR,CHMESS)
37451
37452 C...Double precision and integer declarations.
37453       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37454       INTEGER PYK,PYCHGE,PYCOMP
37455 C...Commonblocks.
37456       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37457       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37458       SAVE /PYJETS/,/PYDAT1/
37459 C...Local character variable.
37460       CHARACTER CHMESS*(*)
37461
37462 C...Write first few warnings, then be silent.
37463       IF(MERR.LE.10) THEN
37464         MSTU(27)=MSTU(27)+1
37465         MSTU(28)=MERR
37466         IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
37467      &  MERR,MSTU(31),CHMESS
37468
37469 C...Write first few errors, then be silent or stop program.
37470       ELSEIF(MERR.LE.20) THEN
37471         MSTU(23)=MSTU(23)+1
37472         MSTU(24)=MERR-10
37473         IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
37474      &  MERR-10,MSTU(31),CHMESS
37475         IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
37476           WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
37477           WRITE(MSTU(11),5200)
37478           IF(MERR.NE.17) CALL PYLIST(2)
37479           STOP
37480         ENDIF
37481
37482 C...Stop program in case of irreparable error.
37483       ELSE
37484         WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
37485         STOP
37486       ENDIF
37487
37488 C...Formats for output.
37489  5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
37490      &' PYEXEC calls:'/5X,A)
37491  5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
37492      &' PYEXEC calls:'/5X,A)
37493  5200 FORMAT(5X,'Execution will be stopped after listing of last ',
37494      &'event!')
37495  5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
37496      &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
37497
37498       RETURN
37499       END
37500
37501 C*********************************************************************
37502
37503 *$ CREATE PYALEM.FOR
37504 *COPY PYALEM
37505 C...PYALEM
37506 C...Calculates the running alpha_electromagnetic.
37507
37508       FUNCTION PYALEM(Q2)
37509
37510 C...Double precision and integer declarations.
37511       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37512       INTEGER PYK,PYCHGE,PYCOMP
37513 C...Commonblocks.
37514       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37515       SAVE /PYDAT1/
37516
37517 C...Calculate real part of photon vacuum polarization.
37518 C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
37519 C...For hadrons use parametrization of H. Burkhardt et al.
37520 C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
37521       AEMPI=PARU(101)/(3D0*PARU(1))
37522       IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
37523         RPIGG=0D0
37524       ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
37525         RPIGG=0D0
37526       ELSEIF(MSTU(101).EQ.2) THEN
37527         RPIGG=1D0-PARU(101)/PARU(103)
37528       ELSEIF(Q2.LT.0.09D0) THEN
37529         RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
37530       ELSEIF(Q2.LT.9D0) THEN
37531         RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
37532      &  0.00238D0*LOG(1D0+3.927D0*Q2)
37533       ELSEIF(Q2.LT.1D4) THEN
37534         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
37535      &  0.00299D0*LOG(1D0+Q2)
37536       ELSE
37537         RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
37538      &  0.00293D0*LOG(1D0+Q2)
37539       ENDIF
37540
37541 C...Calculate running alpha_em.
37542       PYALEM=PARU(101)/(1D0-RPIGG)
37543       PARU(108)=PYALEM
37544
37545       RETURN
37546       END
37547
37548 C*********************************************************************
37549
37550 *$ CREATE PYALPS.FOR
37551 *COPY PYALPS
37552 C...PYALPS
37553 C...Gives the value of alpha_strong.
37554
37555       FUNCTION PYALPS(Q2)
37556
37557 C...Double precision and integer declarations.
37558       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37559       INTEGER PYK,PYCHGE,PYCOMP
37560 C...Commonblocks.
37561       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37562       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37563       SAVE /PYDAT1/,/PYDAT2/
37564
37565 C...Constant alpha_strong trivial. Pick artificial Lambda.
37566       IF(MSTU(111).LE.0) THEN
37567         PYALPS=PARU(111)
37568         MSTU(118)=MSTU(112)
37569         PARU(117)=0.2D0
37570         IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
37571      &  ((33D0-2D0*MSTU(112))*PARU(111)))
37572         PARU(118)=PARU(111)
37573         RETURN
37574       ENDIF
37575
37576 C...Find effective Q2, number of flavours and Lambda.
37577       Q2EFF=Q2
37578       IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
37579       NF=MSTU(112)
37580       ALAM2=PARU(112)**2
37581   100 IF(NF.GT.MAX(2,MSTU(113))) THEN
37582         Q2THR=PARU(113)*PMAS(NF,1)**2
37583         IF(Q2EFF.LT.Q2THR) THEN
37584           NF=NF-1
37585           ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF))
37586           GOTO 100
37587         ENDIF
37588       ENDIF
37589   110 IF(NF.LT.MIN(8,MSTU(114))) THEN
37590         Q2THR=PARU(113)*PMAS(NF+1,1)**2
37591         IF(Q2EFF.GT.Q2THR) THEN
37592           NF=NF+1
37593           ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF))
37594           GOTO 110
37595         ENDIF
37596       ENDIF
37597       IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
37598       PARU(117)=SQRT(ALAM2)
37599
37600 C...Evaluate first or second order alpha_strong.
37601       B0=(33D0-2D0*NF)/6D0
37602       ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
37603       IF(MSTU(111).EQ.1) THEN
37604         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
37605       ELSE
37606         B1=(153D0-19D0*NF)/6D0
37607         PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
37608      &  (B0**2*ALGQ)))
37609       ENDIF
37610       MSTU(118)=NF
37611       PARU(118)=PYALPS
37612
37613       RETURN
37614       END
37615
37616 C*********************************************************************
37617
37618 *$ CREATE PYANGL.FOR
37619 *COPY PYANGL
37620 C...PYANGL
37621 C...Reconstructs an angle from given x and y coordinates.
37622
37623       FUNCTION PYANGL(X,Y)
37624
37625 C...Double precision and integer declarations.
37626       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37627       INTEGER PYK,PYCHGE,PYCOMP
37628 C...Commonblocks.
37629       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37630       SAVE /PYDAT1/
37631
37632       PYANGL=0D0
37633       R=SQRT(X**2+Y**2)
37634       IF(R.LT.1D-20) RETURN
37635       IF(ABS(X)/R.LT.0.8D0) THEN
37636         PYANGL=SIGN(ACOS(X/R),Y)
37637       ELSE
37638         PYANGL=ASIN(Y/R)
37639         IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
37640           PYANGL=PARU(1)-PYANGL
37641         ELSEIF(X.LT.0D0) THEN
37642           PYANGL=-PARU(1)-PYANGL
37643         ENDIF
37644       ENDIF
37645
37646       RETURN
37647       END
37648
37649 C*********************************************************************
37650
37651 *$ CREATE XPYR.FOR
37652 *COPY XPYR
37653 C...PYR
37654 C...Generates random numbers uniformly distributed between
37655 C...0 and 1, excluding the endpoints.
37656
37657 **sr renamed for use of internal dpmjet3 random number generator
37658       FUNCTION XPYR(IDUMMY)
37659 **
37660
37661 C...Double precision and integer declarations.
37662       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37663       INTEGER PYK,PYCHGE,PYCOMP
37664 C...Commonblocks.
37665       COMMON/PYDATR/MRPY(6),RRPY(100)
37666       SAVE /PYDATR/
37667 C...Equivalence between commonblock and local variables.
37668       EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
37669      &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
37670      &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
37671
37672 C...Initialize generation from given seed.
37673       IF(MRPY2.EQ.0) THEN
37674         IJ=MOD(MRPY1/30082,31329)
37675         KL=MOD(MRPY1,30082)
37676         I=MOD(IJ/177,177)+2
37677         J=MOD(IJ,177)+2
37678         K=MOD(KL/169,178)+1
37679         L=MOD(KL,169)
37680         DO 110 II=1,97
37681           S=0D0
37682           T=0.5D0
37683           DO 100 JJ=1,48
37684             M=MOD(MOD(I*J,179)*K,179)
37685             I=J
37686             J=K
37687             K=M
37688             L=MOD(53*L+1,169)
37689             IF(MOD(L*M,64).GE.32) S=S+T
37690             T=0.5D0*T
37691   100     CONTINUE
37692           RRPY(II)=S
37693   110   CONTINUE
37694         TWOM24=1D0
37695         DO 120 I24=1,24
37696           TWOM24=0.5D0*TWOM24
37697   120   CONTINUE
37698         RRPY98=362436D0*TWOM24
37699         RRPY99=7654321D0*TWOM24
37700         RRPY00=16777213D0*TWOM24
37701         MRPY2=1
37702         MRPY3=0
37703         MRPY4=97
37704         MRPY5=33
37705       ENDIF
37706
37707 C...Generate next random number.
37708   130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
37709       IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37710       RRPY(MRPY4)=RUNI
37711       MRPY4=MRPY4-1
37712       IF(MRPY4.EQ.0) MRPY4=97
37713       MRPY5=MRPY5-1
37714       IF(MRPY5.EQ.0) MRPY5=97
37715       RRPY98=RRPY98-RRPY99
37716       IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
37717       RUNI=RUNI-RRPY98
37718       IF(RUNI.LT.0D0) RUNI=RUNI+1D0
37719       IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
37720
37721 C...Update counters. Random number to output.
37722       MRPY3=MRPY3+1
37723       IF(MRPY3.EQ.1000000000) THEN
37724         MRPY2=MRPY2+1
37725         MRPY3=0
37726       ENDIF
37727       XPYR=RUNI
37728
37729       RETURN
37730       END
37731
37732 C*********************************************************************
37733
37734 *$ CREATE PYRGET.FOR
37735 *COPY PYRGET
37736 C...PYRGET
37737 C...Dumps the state of the random number generator on a file
37738 C...for subsequent startup from this state onwards.
37739
37740       SUBROUTINE PYRGET(LFN,MOVE)
37741
37742 C...Double precision and integer declarations.
37743       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37744       INTEGER PYK,PYCHGE,PYCOMP
37745 C...Commonblocks.
37746       COMMON/PYDATR/MRPY(6),RRPY(100)
37747       SAVE /PYDATR/
37748 C...Local character variable.
37749       CHARACTER CHERR*8
37750
37751 C...Backspace required number of records (or as many as there are).
37752       IF(MOVE.LT.0) THEN
37753         NBCK=MIN(MRPY(6),-MOVE)
37754         DO 100 IBCK=1,NBCK
37755           BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
37756   100   CONTINUE
37757         MRPY(6)=MRPY(6)-NBCK
37758       ENDIF
37759
37760 C...Unformatted write on unit LFN.
37761       WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37762      &(RRPY(I2),I2=1,100)
37763       MRPY(6)=MRPY(6)+1
37764       RETURN
37765
37766 C...Write error.
37767   110 WRITE(CHERR,'(I8)') IERR
37768       CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
37769      &CHERR)
37770
37771       RETURN
37772       END
37773
37774 C*********************************************************************
37775
37776 *$ CREATE PYRSET.FOR
37777 *COPY PYRSET
37778 C...PYRSET
37779 C...Reads a state of the random number generator from a file
37780 C...for subsequent generation from this state onwards.
37781
37782       SUBROUTINE PYRSET(LFN,MOVE)
37783
37784 C...Double precision and integer declarations.
37785       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37786       INTEGER PYK,PYCHGE,PYCOMP
37787 C...Commonblocks.
37788       COMMON/PYDATR/MRPY(6),RRPY(100)
37789       SAVE /PYDATR/
37790 C...Local character variable.
37791       CHARACTER CHERR*8
37792
37793 C...Backspace required number of records (or as many as there are).
37794       IF(MOVE.LT.0) THEN
37795         NBCK=MIN(MRPY(6),-MOVE)
37796         DO 100 IBCK=1,NBCK
37797           BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
37798   100   CONTINUE
37799         MRPY(6)=MRPY(6)-NBCK
37800       ENDIF
37801
37802 C...Unformatted read from unit LFN.
37803       NFOR=1+MAX(0,MOVE)
37804       DO 110 IFOR=1,NFOR
37805         READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
37806      &  (RRPY(I2),I2=1,100)
37807   110 CONTINUE
37808       MRPY(6)=MRPY(6)+NFOR
37809       RETURN
37810
37811 C...Write error.
37812   120 WRITE(CHERR,'(I8)') IERR
37813       CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
37814      &CHERR)
37815
37816       RETURN
37817       END
37818
37819 C*********************************************************************
37820
37821 *$ CREATE PYROBO.FOR
37822 *COPY PYROBO
37823 C...PYROBO
37824 C...Performs rotations and boosts.
37825
37826       SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
37827
37828 C...Double precision and integer declarations.
37829       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37830       INTEGER PYK,PYCHGE,PYCOMP
37831 C...Commonblocks.
37832       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37833       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37834       SAVE /PYJETS/,/PYDAT1/
37835 C...Local arrays.
37836       DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
37837
37838 C...Find and check range of rotation/boost.
37839       IMIN=IMI
37840       IF(IMIN.LE.0) IMIN=1
37841       IF(MSTU(1).GT.0) IMIN=MSTU(1)
37842       IMAX=IMA
37843       IF(IMAX.LE.0) IMAX=N
37844       IF(MSTU(2).GT.0) IMAX=MSTU(2)
37845       IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
37846         CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
37847         RETURN
37848       ENDIF
37849
37850 C...Optional resetting of V (when not set before.)
37851       IF(MSTU(33).NE.0) THEN
37852         DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
37853           DO 100 J=1,5
37854             V(I,J)=0D0
37855   100     CONTINUE
37856   110   CONTINUE
37857         MSTU(33)=0
37858       ENDIF
37859
37860 C...Rotate, typically from z axis to direction (theta,phi).
37861       IF(THE**2+PHI**2.GT.1D-20) THEN
37862         ROT(1,1)=COS(THE)*COS(PHI)
37863         ROT(1,2)=-SIN(PHI)
37864         ROT(1,3)=SIN(THE)*COS(PHI)
37865         ROT(2,1)=COS(THE)*SIN(PHI)
37866         ROT(2,2)=COS(PHI)
37867         ROT(2,3)=SIN(THE)*SIN(PHI)
37868         ROT(3,1)=-SIN(THE)
37869         ROT(3,2)=0D0
37870         ROT(3,3)=COS(THE)
37871         DO 140 I=IMIN,IMAX
37872           IF(K(I,1).LE.0) GOTO 140
37873           DO 120 J=1,3
37874             PR(J)=P(I,J)
37875             VR(J)=V(I,J)
37876   120     CONTINUE
37877           DO 130 J=1,3
37878             P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
37879             V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
37880   130     CONTINUE
37881   140   CONTINUE
37882       ENDIF
37883
37884 C...Boost, typically from rest to momentum/energy=beta.
37885       IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
37886         DBX=BEX
37887         DBY=BEY
37888         DBZ=BEZ
37889         DB=SQRT(DBX**2+DBY**2+DBZ**2)
37890         EPS1=1D0-1D-12
37891         IF(DB.GT.EPS1) THEN
37892 C...Rescale boost vector if too close to unity.
37893           CALL PYERRM(3,'(PYROBO:) boost vector too large')
37894           DBX=DBX*(EPS1/DB)
37895           DBY=DBY*(EPS1/DB)
37896           DBZ=DBZ*(EPS1/DB)
37897           DB=EPS1
37898         ENDIF
37899         DGA=1D0/SQRT(1D0-DB**2)
37900         DO 160 I=IMIN,IMAX
37901           IF(K(I,1).LE.0) GOTO 160
37902           DO 150 J=1,4
37903             DP(J)=P(I,J)
37904             DV(J)=V(I,J)
37905   150     CONTINUE
37906           DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
37907           DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
37908           P(I,1)=DP(1)+DGABP*DBX
37909           P(I,2)=DP(2)+DGABP*DBY
37910           P(I,3)=DP(3)+DGABP*DBZ
37911           P(I,4)=DGA*(DP(4)+DBP)
37912           DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
37913           DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
37914           V(I,1)=DV(1)+DGABV*DBX
37915           V(I,2)=DV(2)+DGABV*DBY
37916           V(I,3)=DV(3)+DGABV*DBZ
37917           V(I,4)=DGA*(DV(4)+DBV)
37918   160   CONTINUE
37919       ENDIF
37920
37921       RETURN
37922       END
37923
37924 C*********************************************************************
37925
37926 *$ CREATE PYEDIT.FOR
37927 *COPY PYEDIT
37928 C...PYEDIT
37929 C...Performs global manipulations on the event record, in particular
37930 C...to exclude unstable or undetectable partons/particles.
37931
37932       SUBROUTINE PYEDIT(MEDIT)
37933
37934 C...Double precision and integer declarations.
37935       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37936       INTEGER PYK,PYCHGE,PYCOMP
37937 C...Commonblocks.
37938       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37939       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37940       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37941       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
37942 C...Local arrays.
37943       DIMENSION NS(2),PTS(2),PLS(2)
37944
37945 C...Remove unwanted partons/particles.
37946       IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
37947         IMAX=N
37948         IF(MSTU(2).GT.0) IMAX=MSTU(2)
37949         I1=MAX(1,MSTU(1))-1
37950         DO 110 I=MAX(1,MSTU(1)),IMAX
37951           IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110
37952           IF(MEDIT.EQ.1) THEN
37953             IF(K(I,1).GT.10) GOTO 110
37954           ELSEIF(MEDIT.EQ.2) THEN
37955             IF(K(I,1).GT.10) GOTO 110
37956             KC=PYCOMP(K(I,2))
37957             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18)
37958      &      GOTO 110
37959           ELSEIF(MEDIT.EQ.3) THEN
37960             IF(K(I,1).GT.10) GOTO 110
37961             KC=PYCOMP(K(I,2))
37962             IF(KC.EQ.0) GOTO 110
37963             IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
37964           ELSEIF(MEDIT.EQ.5) THEN
37965             IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110
37966             KC=PYCOMP(K(I,2))
37967             IF(KC.EQ.0) GOTO 110
37968             IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110
37969           ENDIF
37970
37971 C...Pack remaining partons/particles. Origin no longer known.
37972           I1=I1+1
37973           DO 100 J=1,5
37974             K(I1,J)=K(I,J)
37975             P(I1,J)=P(I,J)
37976             V(I1,J)=V(I,J)
37977   100     CONTINUE
37978           K(I1,3)=0
37979   110   CONTINUE
37980         IF(I1.LT.N) MSTU(3)=0
37981         IF(I1.LT.N) MSTU(70)=0
37982         N=I1
37983
37984 C...Selective removal of class of entries. New position of retained.
37985       ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
37986         I1=0
37987         DO 120 I=1,N
37988           K(I,3)=MOD(K(I,3),MSTU(5))
37989           IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
37990           IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
37991           IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
37992      &    K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120
37993           IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
37994      &    K(I,2).EQ.94)) GOTO 120
37995           IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120
37996           I1=I1+1
37997           K(I,3)=K(I,3)+MSTU(5)*I1
37998   120   CONTINUE
37999
38000 C...Find new event history information and replace old.
38001         DO 140 I=1,N
38002           IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0)
38003      &    GOTO 140
38004           ID=I
38005   130     IM=MOD(K(ID,3),MSTU(5))
38006           IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
38007             IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND.
38008      &      K(IM,2).NE.94) THEN
38009               ID=IM
38010               GOTO 130
38011             ENDIF
38012           ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
38013             IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN
38014               ID=IM
38015               GOTO 130
38016             ENDIF
38017           ENDIF
38018           K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
38019           IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
38020           IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
38021             IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
38022      &      K(K(I,4),3)/MSTU(5)
38023             IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
38024      &      K(K(I,5),3)/MSTU(5)
38025           ELSE
38026             KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
38027             IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38028             KCD=MOD(K(I,4),MSTU(5))
38029             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38030             K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38031             KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
38032             IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
38033             KCD=MOD(K(I,5),MSTU(5))
38034             IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
38035             K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
38036           ENDIF
38037   140   CONTINUE
38038
38039 C...Pack remaining entries.
38040         I1=0
38041         MSTU90=MSTU(90)
38042         MSTU(90)=0
38043         DO 170 I=1,N
38044           IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
38045           I1=I1+1
38046           DO 150 J=1,5
38047             K(I1,J)=K(I,J)
38048             P(I1,J)=P(I,J)
38049             V(I1,J)=V(I,J)
38050   150     CONTINUE
38051           K(I1,3)=MOD(K(I1,3),MSTU(5))
38052           DO 160 IZ=1,MSTU90
38053             IF(I.EQ.MSTU(90+IZ)) THEN
38054               MSTU(90)=MSTU(90)+1
38055               MSTU(90+MSTU(90))=I1
38056               PARU(90+MSTU(90))=PARU(90+IZ)
38057             ENDIF
38058   160     CONTINUE
38059   170   CONTINUE
38060         IF(I1.LT.N) MSTU(3)=0
38061         IF(I1.LT.N) MSTU(70)=0
38062         N=I1
38063
38064 C...Fill in some missing daughter pointers (lost in colour flow).
38065       ELSEIF(MEDIT.EQ.16) THEN
38066         DO 220 I=1,N
38067           IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220
38068           IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
38069 C...Find daughters who point to mother.
38070           DO 180 I1=I+1,N
38071             IF(K(I1,3).NE.I) THEN
38072             ELSEIF(K(I,4).EQ.0) THEN
38073               K(I,4)=I1
38074             ELSE
38075               K(I,5)=I1
38076             ENDIF
38077   180     CONTINUE
38078           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38079           IF(K(I,4).NE.0) GOTO 220
38080 C...Find daughters who point to documentation version of mother.
38081           IM=K(I,3)
38082           IF(IM.LE.0.OR.IM.GE.I) GOTO 220
38083           IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
38084           IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
38085           DO 190 I1=I+1,N
38086             IF(K(I1,3).NE.IM) THEN
38087             ELSEIF(K(I,4).EQ.0) THEN
38088               K(I,4)=I1
38089             ELSE
38090               K(I,5)=I1
38091             ENDIF
38092   190     CONTINUE
38093           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38094           IF(K(I,4).NE.0) GOTO 220
38095 C...Find daughters who point to documentation daughters who,
38096 C...in their turn, point to documentation mother.
38097           ID1=IM
38098           ID2=IM
38099           DO 200 I1=IM+1,I-1
38100             IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN
38101               ID2=I1
38102               IF(ID1.EQ.IM) ID1=I1
38103             ENDIF
38104   200     CONTINUE
38105           DO 210 I1=I+1,N
38106             IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
38107             ELSEIF(K(I,4).EQ.0) THEN
38108               K(I,4)=I1
38109             ELSE
38110               K(I,5)=I1
38111             ENDIF
38112   210     CONTINUE
38113           IF(K(I,5).EQ.0) K(I,5)=K(I,4)
38114   220   CONTINUE
38115
38116 C...Save top entries at bottom of PYJETS commonblock.
38117       ELSEIF(MEDIT.EQ.21) THEN
38118         IF(2*N.GE.MSTU(4)) THEN
38119           CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
38120           RETURN
38121         ENDIF
38122         DO 240 I=1,N
38123           DO 230 J=1,5
38124             K(MSTU(4)-I,J)=K(I,J)
38125             P(MSTU(4)-I,J)=P(I,J)
38126             V(MSTU(4)-I,J)=V(I,J)
38127   230     CONTINUE
38128   240   CONTINUE
38129         MSTU(32)=N
38130
38131 C...Restore bottom entries of commonblock PYJETS to top.
38132       ELSEIF(MEDIT.EQ.22) THEN
38133         DO 260 I=1,MSTU(32)
38134           DO 250 J=1,5
38135             K(I,J)=K(MSTU(4)-I,J)
38136             P(I,J)=P(MSTU(4)-I,J)
38137             V(I,J)=V(MSTU(4)-I,J)
38138   250     CONTINUE
38139   260   CONTINUE
38140         N=MSTU(32)
38141
38142 C...Mark primary entries at top of commonblock PYJETS as untreated.
38143       ELSEIF(MEDIT.EQ.23) THEN
38144         I1=0
38145         DO 270 I=1,N
38146           KH=K(I,3)
38147           IF(KH.GE.1) THEN
38148             IF(K(KH,1).GT.20) KH=0
38149           ENDIF
38150           IF(KH.NE.0) GOTO 280
38151           I1=I1+1
38152           IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
38153   270   CONTINUE
38154   280   N=I1
38155
38156 C...Place largest axis along z axis and second largest in xy plane.
38157       ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
38158         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
38159      &  P(MSTU(61),2)),0D0,0D0,0D0)
38160         CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
38161      &  P(MSTU(61),1)),0D0,0D0,0D0,0D0)
38162         CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
38163      &  P(MSTU(61)+1,2)),0D0,0D0,0D0)
38164         IF(MEDIT.EQ.31) RETURN
38165
38166 C...Rotate to put slim jet along +z axis.
38167         DO 290 IS=1,2
38168           NS(IS)=0
38169           PTS(IS)=0D0
38170           PLS(IS)=0D0
38171   290   CONTINUE
38172         DO 300 I=1,N
38173           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
38174           IF(MSTU(41).GE.2) THEN
38175             KC=PYCOMP(K(I,2))
38176             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38177      &      KC.EQ.18) GOTO 300
38178             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38179      &      .EQ.0) GOTO 300
38180           ENDIF
38181           IS=2D0-SIGN(0.5D0,P(I,3))
38182           NS(IS)=NS(IS)+1
38183           PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
38184   300   CONTINUE
38185         IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
38186      &  CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
38187
38188 C...Rotate to put second largest jet into -z,+x quadrant.
38189         DO 310 I=1,N
38190           IF(P(I,3).GE.0D0) GOTO 310
38191           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
38192           IF(MSTU(41).GE.2) THEN
38193             KC=PYCOMP(K(I,2))
38194             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
38195      &      KC.EQ.18) GOTO 310
38196             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
38197      &      .EQ.0) GOTO 310
38198           ENDIF
38199           IS=2D0-SIGN(0.5D0,P(I,1))
38200           PLS(IS)=PLS(IS)-P(I,3)
38201   310   CONTINUE
38202         IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
38203      &  0D0,0D0,0D0)
38204       ENDIF
38205
38206       RETURN
38207       END
38208
38209 C*********************************************************************
38210
38211 *$ CREATE PYLIST.FOR
38212 *COPY PYLIST
38213 C...PYLIST
38214 C...Gives program heading, or lists an event, or particle
38215 C...data, or current parameter values.
38216
38217       SUBROUTINE PYLIST(MLIST)
38218
38219 C...Double precision and integer declarations.
38220       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38221       INTEGER PYK,PYCHGE,PYCOMP
38222 C...Parameter statement to help give large particle numbers.
38223       PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
38224 C...Commonblocks.
38225       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38226       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38227       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38228       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38229       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
38230 C...Local arrays, character variables and data.
38231       CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
38232       DIMENSION PS(6)
38233       DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
38234
38235 C...Initialization printout: version number and date of last change.
38236       IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
38237         CALL PYLOGO
38238         MSTU(12)=0
38239         IF(MLIST.EQ.0) RETURN
38240       ENDIF
38241
38242 C...List event data, including additional lines after N.
38243       IF(MLIST.GE.1.AND.MLIST.LE.3) THEN
38244         IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
38245         IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
38246         IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
38247         LMX=12
38248         IF(MLIST.GE.2) LMX=16
38249         ISTR=0
38250         IMAX=N
38251         IF(MSTU(2).GT.0) IMAX=MSTU(2)
38252         DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
38253           IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120
38254
38255 C...Get particle name, pad it and check it is not too long.
38256           CALL PYNAME(K(I,2),CHAP)
38257           LEN=0
38258           DO 100 LEM=1,16
38259             IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
38260   100     CONTINUE
38261           MDL=(K(I,1)+19)/10
38262           LDL=0
38263           IF(MDL.EQ.2.OR.MDL.GE.8) THEN
38264             CHAC=CHAP
38265             IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
38266           ELSE
38267             LDL=1
38268             IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
38269             IF(LEN.EQ.0) THEN
38270               CHAC=CHDL(MDL)(1:2*LDL)//' '
38271             ELSE
38272               CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
38273      &        CHDL(MDL)(LDL+1:2*LDL)//' '
38274               IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
38275             ENDIF
38276           ENDIF
38277
38278 C...Add information on string connection.
38279           IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
38280      &    THEN
38281             KC=PYCOMP(K(I,2))
38282             KCC=0
38283             IF(KC.NE.0) KCC=KCHG(KC,2)
38284             IF(IABS(K(I,2)).EQ.39) THEN
38285               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
38286             ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
38287               ISTR=1
38288               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
38289             ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
38290               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
38291             ELSEIF(KCC.NE.0) THEN
38292               ISTR=0
38293               IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
38294             ENDIF
38295           ENDIF
38296
38297 C...Write data for particle/jet.
38298           IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
38299             WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3),
38300      &      (P(I,J2),J2=1,5)
38301           ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
38302             WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
38303      &      (P(I,J2),J2=1,5)
38304           ELSEIF(MLIST.EQ.1) THEN
38305             WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
38306      &      (P(I,J2),J2=1,5)
38307           ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
38308      &      K(I,1).EQ.14)) THEN
38309             WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3),
38310      &      K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
38311      &      K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
38312      &      (P(I,J2),J2=1,5)
38313           ELSE
38314             WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5),
38315      &      (P(I,J2),J2=1,5)
38316           ENDIF
38317           IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5)
38318
38319 C...Insert extra separator lines specified by user.
38320           IF(MSTU(70).GE.1) THEN
38321             ISEP=0
38322             DO 110 J=1,MIN(10,MSTU(70))
38323               IF(I.EQ.MSTU(70+J)) ISEP=1
38324   110       CONTINUE
38325             IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000)
38326             IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100)
38327           ENDIF
38328   120   CONTINUE
38329
38330 C...Sum of charges and momenta.
38331         DO 130 J=1,6
38332           PS(J)=PYP(0,J)
38333   130   CONTINUE
38334         IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
38335           WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5)
38336         ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
38337           WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5)
38338         ELSEIF(MLIST.EQ.1) THEN
38339           WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5)
38340         ELSE
38341           WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5)
38342         ENDIF
38343
38344 C...Give simple list of KF codes defined in program.
38345       ELSEIF(MLIST.EQ.11) THEN
38346         WRITE(MSTU(11),6600)
38347         DO 140 KF=1,80
38348           CALL PYNAME(KF,CHAP)
38349           CALL PYNAME(-KF,CHAN)
38350           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38351           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38352   140   CONTINUE
38353         DO 170 KFLS=1,3,2
38354           DO 160 KFLA=1,5
38355             DO 150 KFLB=1,KFLA-(3-KFLS)/2
38356               KF=1000*KFLA+100*KFLB+KFLS
38357               CALL PYNAME(KF,CHAP)
38358               CALL PYNAME(-KF,CHAN)
38359               WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38360   150       CONTINUE
38361   160     CONTINUE
38362   170   CONTINUE
38363         KF=130
38364         CALL PYNAME(KF,CHAP)
38365         WRITE(MSTU(11),6700) KF,CHAP
38366         KF=310
38367         CALL PYNAME(KF,CHAP)
38368         WRITE(MSTU(11),6700) KF,CHAP
38369         DO 200 KMUL=0,5
38370           KFLS=3
38371           IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
38372           IF(KMUL.EQ.5) KFLS=5
38373           KFLR=0
38374           IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
38375           IF(KMUL.EQ.4) KFLR=2
38376           DO 190 KFLB=1,5
38377             DO 180 KFLC=1,KFLB-1
38378               KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
38379               CALL PYNAME(KF,CHAP)
38380               CALL PYNAME(-KF,CHAN)
38381               WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38382   180       CONTINUE
38383             KF=10000*KFLR+110*KFLB+KFLS
38384             CALL PYNAME(KF,CHAP)
38385             WRITE(MSTU(11),6700) KF,CHAP
38386   190     CONTINUE
38387   200   CONTINUE
38388         KF=100443
38389         CALL PYNAME(KF,CHAP)
38390         WRITE(MSTU(11),6700) KF,CHAP
38391         KF=100553
38392         CALL PYNAME(KF,CHAP)
38393         WRITE(MSTU(11),6700) KF,CHAP
38394         DO 240 KFLSP=1,3
38395           KFLS=2+2*(KFLSP/3)
38396           DO 230 KFLA=1,5
38397             DO 220 KFLB=1,KFLA
38398               DO 210 KFLC=1,KFLB
38399                 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
38400      &          GOTO 210
38401                 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210
38402                 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
38403                 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
38404                 CALL PYNAME(KF,CHAP)
38405                 CALL PYNAME(-KF,CHAN)
38406                 WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38407   210         CONTINUE
38408   220       CONTINUE
38409   230     CONTINUE
38410   240   CONTINUE
38411         DO 250 KF=KSUSY1+1,KSUSY1+40
38412           CALL PYNAME(KF,CHAP)
38413           CALL PYNAME(-KF,CHAN)
38414           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38415           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38416   250   CONTINUE
38417         DO 260 KF=KSUSY2+1,KSUSY2+40
38418           CALL PYNAME(KF,CHAP)
38419           CALL PYNAME(-KF,CHAN)
38420           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38421           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38422   260   CONTINUE
38423         DO 270 KF=KEXCIT+1,KEXCIT+40
38424           CALL PYNAME(KF,CHAP)
38425           CALL PYNAME(-KF,CHAN)
38426           IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP
38427           IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN
38428   270   CONTINUE
38429
38430 C...List parton/particle data table. Check whether to be listed.
38431       ELSEIF(MLIST.EQ.12) THEN
38432         WRITE(MSTU(11),6800)
38433         DO 300 KC=1,MSTU(6)
38434           KF=KCHG(KC,4)
38435           IF(KF.EQ.0) GOTO 300
38436           IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
38437      &    GOTO 300
38438
38439 C...Find particle name and mass. Print information.
38440           CALL PYNAME(KF,CHAP)
38441           IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
38442           CALL PYNAME(-KF,CHAN)
38443           WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
38444      &    (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
38445
38446 C...Particle decay: channel number, branching ratios, matrix element,
38447 C...decay products.
38448           DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38449             DO 280 J=1,5
38450               CALL PYNAME(KFDP(IDC,J),CHAD(J))
38451   280       CONTINUE
38452             WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38453      &      (CHAD(J),J=1,5)
38454   290     CONTINUE
38455   300   CONTINUE
38456
38457 C...List parameter value table.
38458       ELSEIF(MLIST.EQ.13) THEN
38459         WRITE(MSTU(11),7100)
38460         DO 310 I=1,200
38461           WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
38462   310   CONTINUE
38463       ENDIF
38464
38465 C...Format statements for output on unit MSTU(11) (by default 6).
38466  5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
38467      &5X,'KF  orig    p_x      p_y      p_z       E        m'/)
38468  5200 FORMAT(///28X,'Event listing (standard)'//4X,'I  particle/jet',
38469      &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
38470      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)
38471  5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I  particle/j',
38472      &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',
38473      &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73X,
38474      &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)
38475  5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
38476  5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
38477  5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
38478  5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
38479  5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
38480  5900 FORMAT(66X,5(1X,F12.3))
38481  6000 FORMAT(1X,78('='))
38482  6100 FORMAT(1X,130('='))
38483  6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
38484  6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
38485  6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
38486  6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
38487      &5F13.5)
38488  6600 FORMAT(///20X,'List of KF codes in program'/)
38489  6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
38490  6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
38491      &'particle',8X,'antiparticle',6X,'chg  col  anti',8X,'mass',7X,
38492      &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
38493      &1X,'ME',3X,'Br.rat.',4X,'decay products')
38494  6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
38495      &1X,1P,E13.5,3X,I2)
38496  7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
38497  7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
38498      &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
38499  7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
38500
38501       RETURN
38502       END
38503
38504 C*********************************************************************
38505
38506 *$ CREATE PYLOGO.FOR
38507 *COPY PYLOGO
38508 C...PYLOGO
38509 C...Writes a logo for the program.
38510
38511       SUBROUTINE PYLOGO
38512
38513 C...Double precision and integer declarations.
38514       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38515       INTEGER PYK,PYCHGE,PYCOMP
38516 C...Parameter for length of information block.
38517       PARAMETER (IREFER=17)
38518 C...Commonblocks.
38519       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38520       COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38521       SAVE /PYDAT1/,/PYPARS/
38522 C...Local arrays and character variables.
38523       INTEGER IDATI(6)
38524       CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
38525      &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
38526
38527 C...Data on months, logo, titles, and references.
38528       DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
38529      &'Oct','Nov','Dec'/
38530       DATA (LOGO(J),J=1,19)/
38531      &'            *......*            ',
38532      &'       *:::!!:::::::::::*       ',
38533      &'    *::::::!!::::::::::::::*    ',
38534      &'  *::::::::!!::::::::::::::::*  ',
38535      &' *:::::::::!!:::::::::::::::::* ',
38536      &' *:::::::::!!:::::::::::::::::* ',
38537      &'  *::::::::!!::::::::::::::::*! ',
38538      &'    *::::::!!::::::::::::::* !! ',
38539      &'    !! *:::!!:::::::::::*    !! ',
38540      &'    !!     !* -><- *         !! ',
38541      &'    !!     !!                !! ',
38542      &'    !!     !!                !! ',
38543      &'    !!                       !! ',
38544      &'    !!        ep             !! ',
38545      &'    !!                       !! ',
38546      &'    !!                 pp    !! ',
38547      &'    !!   e+e-                !! ',
38548      &'    !!                       !! ',
38549      &'    !!                          '/
38550       DATA (LOGO(J),J=20,38)/
38551      &'Welcome to the Lund Monte Carlo!',
38552      &'                                ',
38553      &'PPP  Y   Y TTTTT H   H III   A  ',
38554      &'P  P  Y Y    T   H   H  I   A A ',
38555      &'PPP    Y     T   HHHHH  I  AAAAA',
38556      &'P      Y     T   H   H  I  A   A',
38557      &'P      Y     T   H   H III A   A',
38558      &'                                ',
38559      &'This is PYTHIA version x.xxx    ',
38560      &'Last date of change: xx xxx 199x',
38561      &'                                ',
38562      &'Now is xx xxx 199x at xx:xx:xx  ',
38563      &'                                ',
38564      &'Disclaimer: this program comes  ',
38565      &'without any guarantees. Beware  ',
38566      &'of errors and use common sense  ',
38567      &'when interpreting results.      ',
38568      &'                                ',
38569      &'Copyright T. Sjostrand (1997)   '/
38570       DATA (REFER(J),J=1,18)/
38571      &'An archive of program versions and d',
38572      &'ocumentation is found on the web:   ',
38573      &'http://www.thep.lu.se/tf2/staff/torb',
38574      &'jorn/Pythia.html                    ',
38575      &'                                    ',
38576      &'                                    ',
38577      &'When you cite this program, currentl',
38578      &'y the official reference is         ',
38579      &'T. Sjostrand, Computer Physics Commu',
38580      &'n. 82 (1994) 74.                    ',
38581      &'The supersymmetry extensions are des',
38582      &'cribed in                           ',
38583      &'S. Mrenna, Computer Physics Commun. ',
38584      &'101 (1997) 232                      ',
38585      &'Also remember that the program, to a',
38586      &' large extent, represents original  ',
38587      &'physics research. Other publications',
38588      &' of special relevance to your       '/
38589       DATA (REFER(J),J=19,2*IREFER)/
38590      &'studies may therefore deserve separa',
38591      &'te mention.                         ',
38592      &'                                    ',
38593      &'                                    ',
38594      &'Main author: Torbjorn Sjostrand; Dep',
38595      &'artment of Theoretical Physics 2,   ',
38596      &'  Lund University, Solvegatan 14A, S',
38597      &'-223 62 Lund, Sweden;               ',
38598      &'  phone: + 46 - 46 - 222 48 16; e-ma',
38599      &'il: torbjorn@thep.lu.se             ',
38600      &'SUSY author: Stephen Mrenna, Argonne',
38601      &' National Laboratory,               ',
38602      &'  9700 South Cass Avenue, Argonne, I',
38603      &'L 60439, USA;                       ',
38604      &'  phone: + 1 - 630 - 252 - 7615; e-m',
38605      &'ail: mrenna@hep.anl.gov             '/
38606
38607 C...Check that PYDATA linked.
38608       IF(MSTP(183)/10.NE.199) THEN
38609         WRITE(MSTU(11),'(1X,A)')
38610      &  'Error: PYDATA has not been linked.'
38611         WRITE(MSTU(11),'(1X,A)') 'Execution stopped!'
38612         STOP
38613
38614 C...Write current version number and current date+time.
38615       ELSE
38616         WRITE(VERS,'(I1)') MSTP(181)
38617         LOGO(28)(24:24)=VERS
38618         WRITE(SUBV,'(I3)') MSTP(182)
38619         LOGO(28)(26:28)=SUBV
38620         IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
38621         WRITE(DATE,'(I2)') MSTP(185)
38622         LOGO(29)(22:23)=DATE
38623         LOGO(29)(25:27)=MONTH(MSTP(184))
38624         WRITE(YEAR,'(I4)') MSTP(183)
38625         LOGO(29)(29:32)=YEAR
38626         CALL PYTIME(IDATI)
38627         IF(IDATI(1).LE.0) THEN
38628           LOGO(31)='                                '
38629         ELSE
38630           WRITE(DATE,'(I2)') IDATI(3)
38631           LOGO(31)(8:9)=DATE
38632           LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
38633           WRITE(YEAR,'(I4)') IDATI(1)
38634           LOGO(31)(15:18)=YEAR
38635           WRITE(HOUR,'(I2)') IDATI(4)
38636           LOGO(31)(23:24)=HOUR
38637           WRITE(MINU,'(I2)') IDATI(5)
38638           LOGO(31)(26:27)=MINU
38639           IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
38640           WRITE(SECO,'(I2)') IDATI(6)
38641           LOGO(31)(29:30)=SECO
38642           IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
38643         ENDIF
38644       ENDIF
38645
38646 C...Loop over lines in header. Define page feed and side borders.
38647       DO 100 ILIN=1,29+IREFER
38648         LINE=' '
38649         IF(ILIN.EQ.1) THEN
38650           LINE(1:1)='1'
38651         ELSE
38652           LINE(2:3)='**'
38653           LINE(78:79)='**'
38654         ENDIF
38655
38656 C...Separator lines and logos.
38657         IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
38658           LINE(4:77)='***********************************************'//
38659      &    '***************************'
38660         ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
38661           LINE(6:37)=LOGO(ILIN-5)
38662           LINE(44:75)=LOGO(ILIN+14)
38663         ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
38664           LINE(5:40)=REFER(2*ILIN-51)
38665           LINE(41:76)=REFER(2*ILIN-50)
38666         ENDIF
38667
38668 C...Write lines to appropriate unit.
38669         WRITE(MSTU(11),'(A79)') LINE
38670   100 CONTINUE
38671
38672       RETURN
38673       END
38674
38675 C*********************************************************************
38676
38677 *$ CREATE PYUPDA.FOR
38678 *COPY PYUPDA
38679 C...PYUPDA
38680 C...Facilitates the updating of particle and decay data
38681 C...by allowing it to be done in an external file.
38682
38683       SUBROUTINE PYUPDA(MUPDA,LFN)
38684
38685 C...Double precision and integer declarations.
38686       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38687       INTEGER PYK,PYCHGE,PYCOMP
38688 C...Commonblocks.
38689       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38690       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38691       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
38692       COMMON/PYDAT4/CHAF(500,2)
38693       CHARACTER CHAF*16
38694       COMMON/PYINT4/MWID(500),WIDS(500,5)
38695       SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
38696 C...Local arrays, character variables and data.
38697       CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
38698      &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
38699       DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
38700      &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
38701      &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ',
38702      &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
38703      &'CHAF(I,1)','CHAF(I,2)','MWID(I)  '/
38704
38705 C...Write header if not yet done.
38706       IF(MSTU(12).GE.1) CALL PYLIST(0)
38707
38708 C...Write information on file for editing.
38709       IF(MUPDA.EQ.1) THEN
38710         DO 110 KC=1,500
38711           WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38712      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38713      &    MWID(KC),MDCY(KC,1)
38714           DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38715             WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
38716      &      (KFDP(IDC,J),J=1,5)
38717   100     CONTINUE
38718   110   CONTINUE
38719
38720 C...Read complete set of information from edited file or
38721 C...read partial set of new or updated information from edited file.
38722       ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
38723
38724 C...Reset counters.
38725         KCC=100
38726         NDC=0
38727         CHKF='         '
38728         IF(MUPDA.EQ.2) THEN
38729           DO 120 I=1,MSTU(6)
38730             KCHG(I,4)=0
38731   120     CONTINUE
38732         ELSE
38733           DO 130 KC=1,MSTU(6)
38734             IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
38735             NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
38736   130     CONTINUE
38737         ENDIF
38738
38739 C...Begin of loop: read new line; unknown whether particle or
38740 C...decay data.
38741   140   READ(LFN,5200,END=190) CHINL
38742
38743 C...Identify particle code and whether already defined  (for MUPDA=3).
38744         IF(CHINL(2:10).NE.'         ') THEN
38745           CHKF=CHINL(2:10)
38746           READ(CHKF,5300) KF
38747           IF(MUPDA.EQ.2) THEN
38748             IF(KF.LE.100) THEN
38749               KC=KF
38750             ELSE
38751               KCC=KCC+1
38752               KC=KCC
38753             ENDIF
38754           ELSE
38755             KCREP=0
38756             IF(KF.LE.100) THEN
38757               KCREP=KF
38758             ELSE
38759               DO 150 KCR=101,KCC
38760                 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
38761   150         CONTINUE
38762             ENDIF
38763 C...Remove duplicate old decay data.
38764             IF(KCREP.NE.0) THEN
38765               IDCREP=MDCY(KCREP,2)
38766               NDCREP=MDCY(KCREP,3)
38767               DO 160 I=1,KCC
38768                 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
38769   160         CONTINUE
38770               DO 180 I=IDCREP,NDC-NDCREP
38771                 MDME(I,1)=MDME(I+NDCREP,1)
38772                 MDME(I,2)=MDME(I+NDCREP,2)
38773                 BRAT(I)=BRAT(I+NDCREP)
38774                 DO 170 J=1,5
38775                   KFDP(I,J)=KFDP(I+NDCREP,J)
38776   170           CONTINUE
38777   180         CONTINUE
38778               NDC=NDC-NDCREP
38779               KC=KCREP
38780             ELSE
38781               KCC=KCC+1
38782               KC=KCC
38783             ENDIF
38784           ENDIF
38785
38786 C...Study line with particle data.
38787           IF(KC.GT.MSTU(6)) CALL PYERRM(27,
38788      &    '(PYUPDA:) Particle arrays full by KF ='//CHKF)
38789           READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
38790      &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
38791      &    MWID(KC),MDCY(KC,1)
38792           MDCY(KC,2)=0
38793           MDCY(KC,3)=0
38794
38795 C...Study line with decay data.
38796         ELSE
38797           NDC=NDC+1
38798           IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
38799      &    '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
38800           IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
38801           MDCY(KC,3)=MDCY(KC,3)+1
38802           READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
38803      &    (KFDP(NDC,J),J=1,5)
38804         ENDIF
38805
38806 C...End of loop; ensure that PYCOMP tables are updated.
38807         GOTO 140
38808   190   CONTINUE
38809         MSTU(20)=0
38810
38811 C...Perform possible tests that new information is consistent.
38812         MSTJ24=MSTJ(24)
38813         MSTJ(24)=0
38814         DO 220 KC=1,MSTU(6)
38815           KF=KCHG(KC,4)
38816           IF(KF.EQ.0) GOTO 220
38817           WRITE(CHKF,5300) KF
38818           IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
38819      &    PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
38820      &    '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
38821           BRSUM=0D0
38822           DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
38823             IF(MDME(IDC,2).GT.80) GOTO 210
38824             KQ=KCHG(KC,1)
38825             PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
38826             MERR=0
38827             DO 200 J=1,5
38828               KP=KFDP(IDC,J)
38829               IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
38830                 IF(KP.EQ.81) KQ=0
38831               ELSEIF(PYCOMP(KP).EQ.0) THEN
38832                 MERR=3
38833               ELSE
38834                 KQ=KQ-PYCHGE(KP)
38835                 PMS=PMS-PYMASS(KP)
38836                 KPC=PYCOMP(KP)
38837                 PMS=PMS-PMAS(KPC,1)
38838                 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
38839      &          PMAS(KPC,3))
38840               ENDIF
38841   200       CONTINUE
38842             IF(KQ.NE.0) MERR=MAX(2,MERR)
38843             IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
38844      &      MERR=MAX(1,MERR)
38845             IF(MERR.EQ.3) CALL PYERRM(17,
38846      &      '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
38847             IF(MERR.EQ.2) CALL PYERRM(17,
38848      &      '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
38849             IF(MERR.EQ.1) CALL PYERRM(7,
38850      &      '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
38851             BRSUM=BRSUM+BRAT(IDC)
38852   210     CONTINUE
38853           WRITE(CHTMP,5500) BRSUM
38854           IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
38855      &    CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
38856      &    CHTMP(9:16)//' for KF ='//CHKF)
38857   220   CONTINUE
38858         MSTJ(24)=MSTJ24
38859
38860 C...Write DATA statements for inclusion in program.
38861       ELSEIF(MUPDA.EQ.4) THEN
38862
38863 C...Find out how many codes and decay channels are actually used.
38864         KCC=0
38865         NDC=0
38866         DO 230 I=1,MSTU(6)
38867           IF(KCHG(I,4).NE.0) THEN
38868             KCC=I
38869             NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
38870           ENDIF
38871   230   CONTINUE
38872
38873 C...Initialize writing of DATA statements for inclusion in program.
38874         DO 300 IVAR=1,22
38875           NDIM=MSTU(6)
38876           IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
38877           NLIN=1
38878           CHLIN=' '
38879           CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
38880           LLIN=35
38881           CHOLD='START'
38882
38883 C...Loop through variables for conversion to characters.
38884           DO 280 IDIM=1,NDIM
38885             IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
38886             IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
38887             IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
38888             IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
38889             IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
38890             IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
38891             IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
38892             IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
38893             IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
38894             IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
38895             IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
38896             IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
38897             IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
38898             IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
38899             IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
38900             IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
38901             IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
38902             IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
38903             IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
38904             IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
38905             IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
38906             IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
38907
38908 C...Replace variables beyond what is properly defined.
38909             IF(IVAR.LE.4) THEN
38910               IF(IDIM.GT.KCC) CHTMP='               0'
38911             ELSEIF(IVAR.LE.8) THEN
38912               IF(IDIM.GT.KCC) CHTMP='             0.0'
38913             ELSEIF(IVAR.LE.11) THEN
38914               IF(IDIM.GT.KCC) CHTMP='               0'
38915             ELSEIF(IVAR.LE.13) THEN
38916               IF(IDIM.GT.NDC) CHTMP='               0'
38917             ELSEIF(IVAR.LE.14) THEN
38918               IF(IDIM.GT.NDC) CHTMP='             0.0'
38919             ELSEIF(IVAR.LE.19) THEN
38920               IF(IDIM.GT.NDC) CHTMP='               0'
38921             ELSEIF(IVAR.LE.21) THEN
38922               IF(IDIM.GT.KCC) CHTMP='                '
38923             ELSE
38924               IF(IDIM.GT.KCC) CHTMP='               0'
38925             ENDIF
38926
38927 C...Length of variable, trailing decimal zeros, quotation marks.
38928             LLOW=1
38929             LHIG=1
38930             DO 240 LL=1,16
38931               IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
38932               IF(CHTMP(LL:LL).NE.' ') LHIG=LL
38933   240       CONTINUE
38934             CHNEW=CHTMP(LLOW:LHIG)//' '
38935             LNEW=1+LHIG-LLOW
38936             IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
38937               LNEW=LNEW+1
38938   250         LNEW=LNEW-1
38939               IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
38940               IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
38941               IF(LNEW.EQ.0) THEN
38942                 CHNEW(1:3)='0D0'
38943                 LNEW=3
38944               ELSE
38945                 CHNEW(LNEW+1:LNEW+2)='D0'
38946                 LNEW=LNEW+2
38947               ENDIF
38948             ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
38949               DO 260 LL=LNEW,1,-1
38950                 IF(CHNEW(LL:LL).EQ.'''') THEN
38951                   CHTMP=CHNEW
38952                   CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
38953                   LNEW=LNEW+1
38954                 ENDIF
38955   260         CONTINUE
38956               LNEW=MIN(14,LNEW)
38957               CHTMP=CHNEW
38958               CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
38959               LNEW=LNEW+2
38960             ENDIF
38961
38962 C...Form composite character string, often including repetition counter.
38963             IF(CHNEW.NE.CHOLD) THEN
38964               NRPT=1
38965               CHOLD=CHNEW
38966               CHCOM=CHNEW
38967               LCOM=LNEW
38968             ELSE
38969               LRPT=LNEW+1
38970               IF(NRPT.GE.2) LRPT=LNEW+3
38971               IF(NRPT.GE.10) LRPT=LNEW+4
38972               IF(NRPT.GE.100) LRPT=LNEW+5
38973               IF(NRPT.GE.1000) LRPT=LNEW+6
38974               LLIN=LLIN-LRPT
38975               NRPT=NRPT+1
38976               WRITE(CHTMP,5400) NRPT
38977               LRPT=1
38978               IF(NRPT.GE.10) LRPT=2
38979               IF(NRPT.GE.100) LRPT=3
38980               IF(NRPT.GE.1000) LRPT=4
38981               CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
38982               LCOM=LRPT+1+LNEW
38983             ENDIF
38984
38985 C...Add characters to end of line, to new line (after storing old line),
38986 C...or to new block of lines (after writing old block).
38987             IF(LLIN+LCOM.LE.70) THEN
38988               CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
38989               LLIN=LLIN+LCOM+1
38990             ELSEIF(NLIN.LE.19) THEN
38991               CHLIN(LLIN+1:72)=' '
38992               CHBLK(NLIN)=CHLIN
38993               NLIN=NLIN+1
38994               CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
38995               LLIN=6+LCOM+1
38996             ELSE
38997               CHLIN(LLIN:72)='/'//' '
38998               CHBLK(NLIN)=CHLIN
38999               WRITE(CHTMP,5400) IDIM-NRPT
39000               CHBLK(1)(30:33)=CHTMP(13:16)
39001               DO 270 ILIN=1,NLIN
39002                 WRITE(LFN,5700) CHBLK(ILIN)
39003   270         CONTINUE
39004               NLIN=1
39005               CHLIN=' '
39006               CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
39007      &        ',I=    ,    )/'//CHCOM(1:LCOM)//','
39008               WRITE(CHTMP,5400) IDIM-NRPT+1
39009               CHLIN(25:28)=CHTMP(13:16)
39010               LLIN=35+LCOM+1
39011             ENDIF
39012   280     CONTINUE
39013
39014 C...Write final block of lines.
39015           CHLIN(LLIN:72)='/'//' '
39016           CHBLK(NLIN)=CHLIN
39017           WRITE(CHTMP,5400) NDIM
39018           CHBLK(1)(30:33)=CHTMP(13:16)
39019           DO 290 ILIN=1,NLIN
39020             WRITE(LFN,5700) CHBLK(ILIN)
39021   290     CONTINUE
39022   300   CONTINUE
39023       ENDIF
39024
39025 C...Formats for reading and writing particle data.
39026  5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
39027  5100 FORMAT(10X,2I5,F12.6,5I10)
39028  5200 FORMAT(A120)
39029  5300 FORMAT(I9)
39030  5400 FORMAT(I16)
39031  5500 FORMAT(F16.5)
39032  5600 FORMAT(F16.6)
39033  5700 FORMAT(A72)
39034
39035       RETURN
39036       END
39037
39038 C*********************************************************************
39039
39040 *$ CREATE PYK.FOR
39041 *COPY PYK
39042 C...PYK
39043 C...Provides various integer-valued event related data.
39044
39045       FUNCTION PYK(I,J)
39046
39047 C...Double precision and integer declarations.
39048       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39049       INTEGER PYK,PYCHGE,PYCOMP
39050 C...Commonblocks.
39051       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39052       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39053       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39054       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39055
39056 C...Default value. For I=0 number of entries, number of stable entries
39057 C...or 3 times total charge.
39058       PYK=0
39059       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39060       ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
39061         PYK=N
39062       ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
39063         DO 100 I1=1,N
39064           IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
39065           IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
39066      &    PYCHGE(K(I1,2))
39067   100   CONTINUE
39068       ELSEIF(I.EQ.0) THEN
39069
39070 C...For I > 0 direct readout of K matrix or charge.
39071       ELSEIF(J.LE.5) THEN
39072         PYK=K(I,J)
39073       ELSEIF(J.EQ.6) THEN
39074         PYK=PYCHGE(K(I,2))
39075
39076 C...Status (existing/fragmented/decayed), parton/hadron separation.
39077       ELSEIF(J.LE.8) THEN
39078         IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
39079         IF(J.EQ.8) PYK=PYK*K(I,2)
39080       ELSEIF(J.LE.12) THEN
39081         KFA=IABS(K(I,2))
39082         KC=PYCOMP(KFA)
39083         KQ=0
39084         IF(KC.NE.0) KQ=KCHG(KC,2)
39085         IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
39086         IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
39087         IF(J.EQ.11) PYK=KC
39088         IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
39089
39090 C...Heaviest flavour in hadron/diquark.
39091       ELSEIF(J.EQ.13) THEN
39092         KFA=IABS(K(I,2))
39093         PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
39094         IF(KFA.LT.10) PYK=KFA
39095         IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
39096         PYK=PYK*ISIGN(1,K(I,2))
39097
39098 C...Particle history: generation, ancestor, rank.
39099       ELSEIF(J.LE.15) THEN
39100         I2=I
39101         I1=I
39102   110   PYK=PYK+1
39103         I2=I1
39104         I1=K(I1,3)
39105         IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
39106         IF(J.EQ.15) PYK=I2
39107       ELSEIF(J.EQ.16) THEN
39108         KFA=IABS(K(I,2))
39109         IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
39110      &  (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
39111           I1=I
39112   120     I2=I1
39113           I1=K(I1,3)
39114           IF(I1.GT.0) THEN
39115             KFAM=IABS(K(I1,2))
39116             ILP=1
39117             IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
39118             IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
39119      &      ILP=0
39120             IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
39121             IF(ILP.EQ.1) GOTO 120
39122           ENDIF
39123           IF(K(I1,1).EQ.12) THEN
39124             DO 130 I3=I1+1,I2
39125               IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
39126      &        .AND.K(I3,2).NE.93) PYK=PYK+1
39127   130       CONTINUE
39128           ELSE
39129             I3=I2
39130   140       PYK=PYK+1
39131             I3=I3+1
39132             IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
39133           ENDIF
39134         ENDIF
39135
39136 C...Particle coming from collapsing jet system or not.
39137       ELSEIF(J.EQ.17) THEN
39138         I1=I
39139   150   PYK=PYK+1
39140         I3=I1
39141         I1=K(I1,3)
39142         I0=MAX(1,I1)
39143         KC=PYCOMP(K(I0,2))
39144         IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
39145           IF(PYK.EQ.1) PYK=-1
39146           IF(PYK.GT.1) PYK=0
39147           RETURN
39148         ENDIF
39149         IF(KCHG(KC,2).EQ.0) GOTO 150
39150         IF(K(I1,1).NE.12) PYK=0
39151         IF(K(I1,1).NE.12) RETURN
39152         I2=I1
39153   160   I2=I2+1
39154         IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
39155         K3M=K(I3-1,3)
39156         IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
39157         K3P=K(I3+1,3)
39158         IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
39159
39160 C...Number of decay products. Colour flow.
39161       ELSEIF(J.EQ.18) THEN
39162         IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
39163         IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
39164       ELSEIF(J.LE.22) THEN
39165         IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
39166         IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
39167         IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
39168         IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
39169         IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
39170       ELSE
39171       ENDIF
39172
39173       RETURN
39174       END
39175
39176 C*********************************************************************
39177
39178 *$ CREATE PYP.FOR
39179 *COPY PYP
39180 C...PYP
39181 C...Provides various real-valued event related data.
39182
39183       FUNCTION PYP(I,J)
39184
39185 C...Double precision and integer declarations.
39186       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39187       INTEGER PYK,PYCHGE,PYCOMP
39188 C...Commonblocks.
39189       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39190       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39191       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39192       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39193 C...Local array.
39194       DIMENSION PSUM(4)
39195
39196 C...Set default value. For I = 0 sum of momenta or charges,
39197 C...or invariant mass of system.
39198       PYP=0D0
39199       IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
39200       ELSEIF(I.EQ.0.AND.J.LE.4) THEN
39201         DO 100 I1=1,N
39202           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
39203   100   CONTINUE
39204       ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
39205         DO 120 J1=1,4
39206           PSUM(J1)=0D0
39207           DO 110 I1=1,N
39208             IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
39209      &      P(I1,J1)
39210   110     CONTINUE
39211   120   CONTINUE
39212         PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
39213       ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
39214         DO 130 I1=1,N
39215           IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
39216   130   CONTINUE
39217       ELSEIF(I.EQ.0) THEN
39218
39219 C...Direct readout of P matrix.
39220       ELSEIF(J.LE.5) THEN
39221         PYP=P(I,J)
39222
39223 C...Charge, total momentum, transverse momentum, transverse mass.
39224       ELSEIF(J.LE.12) THEN
39225         IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
39226         IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
39227         IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
39228         IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
39229         IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
39230
39231 C...Theta and phi angle in radians or degrees.
39232       ELSEIF(J.LE.16) THEN
39233         IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
39234         IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
39235         IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
39236
39237 C...True rapidity, rapidity with pion mass, pseudorapidity.
39238       ELSEIF(J.LE.19) THEN
39239         PMR=0D0
39240         IF(J.EQ.17) PMR=P(I,5)
39241         IF(J.EQ.18) PMR=PYMASS(211)
39242         PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
39243         PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
39244      &  1D20)),P(I,3))
39245
39246 C...Energy and momentum fractions (only to be used in CM frame).
39247       ELSEIF(J.LE.25) THEN
39248         IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
39249         IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
39250         IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
39251         IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
39252         IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
39253         IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
39254       ENDIF
39255
39256       RETURN
39257       END
39258
39259 C*********************************************************************
39260
39261 *$ CREATE PYSPHE.FOR
39262 *COPY PYSPHE
39263 C...PYSPHE
39264 C...Performs sphericity tensor analysis to give sphericity,
39265 C...aplanarity and the related event axes.
39266
39267       SUBROUTINE PYSPHE(SPH,APL)
39268
39269 C...Double precision and integer declarations.
39270       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39271       INTEGER PYK,PYCHGE,PYCOMP
39272 C...Commonblocks.
39273       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39274       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39275       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39276       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39277 C...Local arrays.
39278       DIMENSION SM(3,3),SV(3,3)
39279
39280 C...Calculate matrix to be diagonalized.
39281       NP=0
39282       DO 110 J1=1,3
39283         DO 100 J2=J1,3
39284           SM(J1,J2)=0D0
39285   100   CONTINUE
39286   110 CONTINUE
39287       PS=0D0
39288       DO 140 I=1,N
39289         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39290         IF(MSTU(41).GE.2) THEN
39291           KC=PYCOMP(K(I,2))
39292           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39293      &    KC.EQ.18) GOTO 140
39294           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39295      &    GOTO 140
39296         ENDIF
39297         NP=NP+1
39298         PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39299         PWT=1D0
39300         IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
39301      &  MAX(1D-10,PA)**(PARU(41)-2D0)
39302         DO 130 J1=1,3
39303           DO 120 J2=J1,3
39304             SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
39305   120     CONTINUE
39306   130   CONTINUE
39307         PS=PS+PWT*PA**2
39308   140 CONTINUE
39309
39310 C...Very low multiplicities (0 or 1) not considered.
39311       IF(NP.LE.1) THEN
39312         CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
39313         SPH=-1D0
39314         APL=-1D0
39315         RETURN
39316       ENDIF
39317       DO 160 J1=1,3
39318         DO 150 J2=J1,3
39319           SM(J1,J2)=SM(J1,J2)/PS
39320   150   CONTINUE
39321   160 CONTINUE
39322
39323 C...Find eigenvalues to matrix (third degree equation).
39324       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
39325      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
39326       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
39327      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
39328      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
39329       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
39330       P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
39331       P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
39332       P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
39333       IF(P(N+2,4).LT.1D-5) THEN
39334         CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
39335         SPH=-1D0
39336         APL=-1D0
39337         RETURN
39338       ENDIF
39339
39340 C...Find first and last eigenvector by solving equation system.
39341       DO 240 I=1,3,2
39342         DO 180 J1=1,3
39343           SV(J1,J1)=SM(J1,J1)-P(N+I,4)
39344           DO 170 J2=J1+1,3
39345             SV(J1,J2)=SM(J1,J2)
39346             SV(J2,J1)=SM(J1,J2)
39347   170     CONTINUE
39348   180   CONTINUE
39349         SMAX=0D0
39350         DO 200 J1=1,3
39351           DO 190 J2=1,3
39352             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
39353             JA=J1
39354             JB=J2
39355             SMAX=ABS(SV(J1,J2))
39356   190     CONTINUE
39357   200   CONTINUE
39358         SMAX=0D0
39359         DO 220 J3=JA+1,JA+2
39360           J1=J3-3*((J3-1)/3)
39361           RL=SV(J1,JB)/SV(JA,JB)
39362           DO 210 J2=1,3
39363             SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
39364             IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
39365             JC=J1
39366             SMAX=ABS(SV(J1,J2))
39367   210     CONTINUE
39368   220   CONTINUE
39369         JB1=JB+1-3*(JB/3)
39370         JB2=JB+2-3*((JB+1)/3)
39371         P(N+I,JB1)=-SV(JC,JB2)
39372         P(N+I,JB2)=SV(JC,JB1)
39373         P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
39374      &  SV(JA,JB)
39375         PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
39376         SGN=(-1D0)**INT(PYR(0)+0.5D0)
39377         DO 230 J=1,3
39378           P(N+I,J)=SGN*P(N+I,J)/PA
39379   230   CONTINUE
39380   240 CONTINUE
39381
39382 C...Middle axis orthogonal to other two. Fill other codes.
39383       SGN=(-1D0)**INT(PYR(0)+0.5D0)
39384       P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
39385       P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
39386       P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
39387       DO 260 I=1,3
39388         K(N+I,1)=31
39389         K(N+I,2)=95
39390         K(N+I,3)=I
39391         K(N+I,4)=0
39392         K(N+I,5)=0
39393         P(N+I,5)=0D0
39394         DO 250 J=1,5
39395           V(I,J)=0D0
39396   250   CONTINUE
39397   260 CONTINUE
39398
39399 C...Calculate sphericity and aplanarity. Select storing option.
39400       SPH=1.5D0*(P(N+2,4)+P(N+3,4))
39401       APL=1.5D0*P(N+3,4)
39402       MSTU(61)=N+1
39403       MSTU(62)=NP
39404       IF(MSTU(43).LE.1) MSTU(3)=3
39405       IF(MSTU(43).GE.2) N=N+3
39406
39407       RETURN
39408       END
39409
39410 C*********************************************************************
39411
39412 *$ CREATE PYTHRU.FOR
39413 *COPY PYTHRU
39414 C...PYTHRU
39415 C...Performs thrust analysis to give thrust, oblateness
39416 C...and the related event axes.
39417
39418       SUBROUTINE PYTHRU(THR,OBL)
39419
39420 C...Double precision and integer declarations.
39421       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39422       INTEGER PYK,PYCHGE,PYCOMP
39423 C...Commonblocks.
39424       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39425       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39426       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39427       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39428 C...Local arrays.
39429       DIMENSION TDI(3),TPR(3)
39430
39431 C...Take copy of particles that are to be considered in thrust analysis.
39432       NP=0
39433       PS=0D0
39434       DO 100 I=1,N
39435         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
39436         IF(MSTU(41).GE.2) THEN
39437           KC=PYCOMP(K(I,2))
39438           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39439      &    KC.EQ.18) GOTO 100
39440           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39441      &    GOTO 100
39442         ENDIF
39443         IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
39444           CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
39445           THR=-2D0
39446           OBL=-2D0
39447           RETURN
39448         ENDIF
39449         NP=NP+1
39450         K(N+NP,1)=23
39451         P(N+NP,1)=P(I,1)
39452         P(N+NP,2)=P(I,2)
39453         P(N+NP,3)=P(I,3)
39454         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39455         P(N+NP,5)=1D0
39456         IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
39457      &  P(N+NP,4)**(PARU(42)-1D0)
39458         PS=PS+P(N+NP,4)*P(N+NP,5)
39459   100 CONTINUE
39460
39461 C...Very low multiplicities (0 or 1) not considered.
39462       IF(NP.LE.1) THEN
39463         CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
39464         THR=-1D0
39465         OBL=-1D0
39466         RETURN
39467       ENDIF
39468
39469 C...Loop over thrust and major. T axis along z direction in latter case.
39470       DO 320 ILD=1,2
39471         IF(ILD.EQ.2) THEN
39472           K(N+NP+1,1)=31
39473           PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
39474           MSTU(33)=1
39475           CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
39476           THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
39477           CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
39478         ENDIF
39479
39480 C...Find and order particles with highest p (pT for major).
39481         DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
39482           P(ILF,4)=0D0
39483   110   CONTINUE
39484         DO 160 I=N+1,N+NP
39485           IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
39486           DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
39487             IF(P(I,4).LE.P(ILF,4)) GOTO 140
39488             DO 120 J=1,5
39489               P(ILF+1,J)=P(ILF,J)
39490   120       CONTINUE
39491   130     CONTINUE
39492           ILF=N+NP+3
39493   140     DO 150 J=1,5
39494             P(ILF+1,J)=P(I,J)
39495   150     CONTINUE
39496   160   CONTINUE
39497
39498 C...Find and order initial axes with highest thrust (major).
39499         DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
39500           P(ILG,4)=0D0
39501   170   CONTINUE
39502         NC=2**(MIN(MSTU(44),NP)-1)
39503         DO 250 ILC=1,NC
39504           DO 180 J=1,3
39505             TDI(J)=0D0
39506   180     CONTINUE
39507           DO 200 ILF=1,MIN(MSTU(44),NP)
39508             SGN=P(N+NP+ILF+3,5)
39509             IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
39510             DO 190 J=1,4-ILD
39511               TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
39512   190       CONTINUE
39513   200     CONTINUE
39514           TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
39515           DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
39516             IF(TDS.LE.P(ILG,4)) GOTO 230
39517             DO 210 J=1,4
39518               P(ILG+1,J)=P(ILG,J)
39519   210       CONTINUE
39520   220     CONTINUE
39521           ILG=N+NP+MSTU(44)+4
39522   230     DO 240 J=1,3
39523             P(ILG+1,J)=TDI(J)
39524   240     CONTINUE
39525           P(ILG+1,4)=TDS
39526   250   CONTINUE
39527
39528 C...Iterate direction of axis until stable maximum.
39529         P(N+NP+ILD,4)=0D0
39530         ILG=0
39531   260   ILG=ILG+1
39532         THP=0D0
39533   270   THPS=THP
39534         DO 280 J=1,3
39535           IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
39536           IF(THP.GT.1D-10) TDI(J)=TPR(J)
39537           TPR(J)=0D0
39538   280   CONTINUE
39539         DO 300 I=N+1,N+NP
39540           SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
39541           DO 290 J=1,4-ILD
39542             TPR(J)=TPR(J)+SGN*P(I,J)
39543   290     CONTINUE
39544   300   CONTINUE
39545         THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
39546         IF(THP.GE.THPS+PARU(48)) GOTO 270
39547
39548 C...Save good axis. Try new initial axis until a number of tries agree.
39549         IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
39550         IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
39551           IAGR=0
39552           SGN=(-1D0)**INT(PYR(0)+0.5D0)
39553           DO 310 J=1,3
39554             P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
39555   310     CONTINUE
39556           P(N+NP+ILD,4)=THP
39557           P(N+NP+ILD,5)=0D0
39558         ENDIF
39559         IAGR=IAGR+1
39560         IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
39561   320 CONTINUE
39562
39563 C...Find minor axis and value by orthogonality.
39564       SGN=(-1D0)**INT(PYR(0)+0.5D0)
39565       P(N+NP+3,1)=-SGN*P(N+NP+2,2)
39566       P(N+NP+3,2)=SGN*P(N+NP+2,1)
39567       P(N+NP+3,3)=0D0
39568       THP=0D0
39569       DO 330 I=N+1,N+NP
39570         THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
39571   330 CONTINUE
39572       P(N+NP+3,4)=THP/PS
39573       P(N+NP+3,5)=0D0
39574
39575 C...Fill axis information. Rotate back to original coordinate system.
39576       DO 350 ILD=1,3
39577         K(N+ILD,1)=31
39578         K(N+ILD,2)=96
39579         K(N+ILD,3)=ILD
39580         K(N+ILD,4)=0
39581         K(N+ILD,5)=0
39582         DO 340 J=1,5
39583           P(N+ILD,J)=P(N+NP+ILD,J)
39584           V(N+ILD,J)=0D0
39585   340   CONTINUE
39586   350 CONTINUE
39587       CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
39588
39589 C...Calculate thrust and oblateness. Select storing option.
39590       THR=P(N+1,4)
39591       OBL=P(N+2,4)-P(N+3,4)
39592       MSTU(61)=N+1
39593       MSTU(62)=NP
39594       IF(MSTU(43).LE.1) MSTU(3)=3
39595       IF(MSTU(43).GE.2) N=N+3
39596
39597       RETURN
39598       END
39599
39600 C*********************************************************************
39601
39602 *$ CREATE PYCLUS.FOR
39603 *COPY PYCLUS
39604 C...PYCLUS
39605 C...Subdivides the particle content of an event into jets/clusters.
39606
39607       SUBROUTINE PYCLUS(NJET)
39608
39609 C...Double precision and integer declarations.
39610       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39611       INTEGER PYK,PYCHGE,PYCOMP
39612 C...Commonblocks.
39613       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39614       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39615       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39616       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39617 C...Local arrays and saved variables.
39618       DIMENSION PS(5)
39619       SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
39620
39621 C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
39622       R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
39623      &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
39624       R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
39625      &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39626       R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
39627      &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
39628
39629 C...If first time, reset. If reentering, skip preliminaries.
39630       IF(MSTU(48).LE.0) THEN
39631         NP=0
39632         DO 100 J=1,5
39633           PS(J)=0D0
39634   100   CONTINUE
39635         PSS=0D0
39636         PIMASS=PMAS(PYCOMP(211),1)
39637       ELSE
39638         NJET=NSAV
39639         IF(MSTU(43).GE.2) N=N-NJET
39640         DO 110 I=N+1,N+NJET
39641           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39642   110   CONTINUE
39643         IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39644           R2ACC=PARU(44)**2
39645         ELSE
39646           R2ACC=PARU(45)*PS(5)**2
39647         ENDIF
39648         NLOOP=0
39649         GOTO 300
39650       ENDIF
39651
39652 C...Find which particles are to be considered in cluster search.
39653       DO 140 I=1,N
39654         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
39655         IF(MSTU(41).GE.2) THEN
39656           KC=PYCOMP(K(I,2))
39657           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
39658      &    KC.EQ.18) GOTO 140
39659           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
39660      &    GOTO 140
39661         ENDIF
39662         IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
39663           CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
39664           NJET=-1
39665           RETURN
39666         ENDIF
39667
39668 C...Take copy of these particles, with space left for jets later on.
39669         NP=NP+1
39670         K(N+NP,3)=I
39671         DO 120 J=1,5
39672           P(N+NP,J)=P(I,J)
39673   120   CONTINUE
39674         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
39675         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
39676         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
39677         P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39678         DO 130 J=1,4
39679           PS(J)=PS(J)+P(N+NP,J)
39680   130   CONTINUE
39681         PSS=PSS+P(N+NP,5)
39682   140 CONTINUE
39683       DO 160 I=N+1,N+NP
39684         K(I+NP,3)=K(I,3)
39685         DO 150 J=1,5
39686           P(I+NP,J)=P(I,J)
39687   150   CONTINUE
39688   160 CONTINUE
39689       PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
39690
39691 C...Very low multiplicities not considered.
39692       IF(NP.LT.MSTU(47)) THEN
39693         CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
39694         NJET=-1
39695         RETURN
39696       ENDIF
39697
39698 C...Find precluster configuration. If too few jets, make harder cuts.
39699       NLOOP=0
39700       IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
39701         R2ACC=PARU(44)**2
39702       ELSE
39703         R2ACC=PARU(45)*PS(5)**2
39704       ENDIF
39705       RINIT=1.25D0*PARU(43)
39706       IF(NP.LE.MSTU(47)+2) RINIT=0D0
39707   170 RINIT=0.8D0*RINIT
39708       NPRE=0
39709       NREM=NP
39710       DO 180 I=N+NP+1,N+2*NP
39711         K(I,4)=0
39712   180 CONTINUE
39713
39714 C...Sum up small momentum region. Jet if enough absolute momentum.
39715       IF(MSTU(46).LE.2) THEN
39716         DO 190 J=1,4
39717           P(N+1,J)=0D0
39718   190   CONTINUE
39719         DO 210 I=N+NP+1,N+2*NP
39720           IF(P(I,5).GT.2D0*RINIT) GOTO 210
39721           NREM=NREM-1
39722           K(I,4)=1
39723           DO 200 J=1,4
39724             P(N+1,J)=P(N+1,J)+P(I,J)
39725   200     CONTINUE
39726   210   CONTINUE
39727         P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
39728         IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
39729         IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39730         IF(NREM.EQ.0) GOTO 170
39731       ENDIF
39732
39733 C...Find fastest remaining particle.
39734   220 NPRE=NPRE+1
39735       PMAX=0D0
39736       DO 230 I=N+NP+1,N+2*NP
39737         IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
39738         IMAX=I
39739         PMAX=P(I,5)
39740   230 CONTINUE
39741       DO 240 J=1,5
39742         P(N+NPRE,J)=P(IMAX,J)
39743   240 CONTINUE
39744       NREM=NREM-1
39745       K(IMAX,4)=NPRE
39746
39747 C...Sum up precluster around it according to pT separation.
39748       IF(MSTU(46).LE.2) THEN
39749         DO 260 I=N+NP+1,N+2*NP
39750           IF(K(I,4).NE.0) GOTO 260
39751           R2=R2T(I,IMAX)
39752           IF(R2.GT.RINIT**2) GOTO 260
39753           NREM=NREM-1
39754           K(I,4)=NPRE
39755           DO 250 J=1,4
39756             P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
39757   250     CONTINUE
39758   260   CONTINUE
39759         P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39760
39761 C...Sum up precluster around it according to mass or
39762 C...Durham pT separation.
39763       ELSE
39764   270   IMIN=0
39765         R2MIN=RINIT**2
39766         DO 280 I=N+NP+1,N+2*NP
39767           IF(K(I,4).NE.0) GOTO 280
39768           IF(MSTU(46).LE.4) THEN
39769             R2=R2M(I,N+NPRE)
39770           ELSE
39771             R2=R2D(I,N+NPRE)
39772           ENDIF
39773           IF(R2.GE.R2MIN) GOTO 280
39774           IMIN=I
39775           R2MIN=R2
39776   280   CONTINUE
39777         IF(IMIN.NE.0) THEN
39778           DO 290 J=1,4
39779             P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
39780   290     CONTINUE
39781           P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
39782           NREM=NREM-1
39783           K(IMIN,4)=NPRE
39784           GOTO 270
39785         ENDIF
39786       ENDIF
39787
39788 C...Check if more preclusters to be found. Start over if too few.
39789       IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
39790       IF(NREM.GT.0) GOTO 220
39791       NJET=NPRE
39792
39793 C...Reassign all particles to nearest jet. Sum up new jet momenta.
39794   300 TSAV=0D0
39795       PSJT=0D0
39796   310 IF(MSTU(46).LE.1) THEN
39797         DO 330 I=N+1,N+NJET
39798           DO 320 J=1,4
39799             V(I,J)=0D0
39800   320     CONTINUE
39801   330   CONTINUE
39802         DO 360 I=N+NP+1,N+2*NP
39803           R2MIN=PSS**2
39804           DO 340 IJET=N+1,N+NJET
39805             IF(P(IJET,5).LT.RINIT) GOTO 340
39806             R2=R2T(I,IJET)
39807             IF(R2.GE.R2MIN) GOTO 340
39808             IMIN=IJET
39809             R2MIN=R2
39810   340     CONTINUE
39811           K(I,4)=IMIN-N
39812           DO 350 J=1,4
39813             V(IMIN,J)=V(IMIN,J)+P(I,J)
39814   350     CONTINUE
39815   360   CONTINUE
39816         PSJT=0D0
39817         DO 380 I=N+1,N+NJET
39818           DO 370 J=1,4
39819             P(I,J)=V(I,J)
39820   370     CONTINUE
39821           P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
39822           PSJT=PSJT+P(I,5)
39823   380   CONTINUE
39824       ENDIF
39825
39826 C...Find two closest jets.
39827       R2MIN=2D0*MAX(R2ACC,PS(5)**2)
39828       DO 400 ITRY1=N+1,N+NJET-1
39829         DO 390 ITRY2=ITRY1+1,N+NJET
39830           IF(MSTU(46).LE.2) THEN
39831             R2=R2T(ITRY1,ITRY2)
39832           ELSEIF(MSTU(46).LE.4) THEN
39833             R2=R2M(ITRY1,ITRY2)
39834           ELSE
39835             R2=R2D(ITRY1,ITRY2)
39836           ENDIF
39837           IF(R2.GE.R2MIN) GOTO 390
39838           IMIN1=ITRY1
39839           IMIN2=ITRY2
39840           R2MIN=R2
39841   390   CONTINUE
39842   400 CONTINUE
39843
39844 C...If allowed, join two closest jets and start over.
39845       IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
39846         IREC=MIN(IMIN1,IMIN2)
39847         IDEL=MAX(IMIN1,IMIN2)
39848         DO 410 J=1,4
39849           P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
39850   410   CONTINUE
39851         P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
39852         DO 430 I=IDEL+1,N+NJET
39853           DO 420 J=1,5
39854             P(I-1,J)=P(I,J)
39855   420     CONTINUE
39856   430   CONTINUE
39857         IF(MSTU(46).GE.2) THEN
39858           DO 440 I=N+NP+1,N+2*NP
39859             IORI=N+K(I,4)
39860             IF(IORI.EQ.IDEL) K(I,4)=IREC-N
39861             IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
39862   440     CONTINUE
39863         ENDIF
39864         NJET=NJET-1
39865         GOTO 300
39866
39867 C...Divide up broad jet if empty cluster in list of final ones.
39868       ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
39869         DO 450 I=N+1,N+NJET
39870           K(I,5)=0
39871   450   CONTINUE
39872         DO 460 I=N+NP+1,N+2*NP
39873           K(N+K(I,4),5)=K(N+K(I,4),5)+1
39874   460   CONTINUE
39875         IEMP=0
39876         DO 470 I=N+1,N+NJET
39877           IF(K(I,5).EQ.0) IEMP=I
39878   470   CONTINUE
39879         IF(IEMP.NE.0) THEN
39880           NLOOP=NLOOP+1
39881           ISPL=0
39882           R2MAX=0D0
39883           DO 480 I=N+NP+1,N+2*NP
39884             IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
39885             IJET=N+K(I,4)
39886             R2=R2T(I,IJET)
39887             IF(R2.LE.R2MAX) GOTO 480
39888             ISPL=I
39889             R2MAX=R2
39890   480     CONTINUE
39891           IF(ISPL.NE.0) THEN
39892             IJET=N+K(ISPL,4)
39893             DO 490 J=1,4
39894               P(IEMP,J)=P(ISPL,J)
39895               P(IJET,J)=P(IJET,J)-P(ISPL,J)
39896   490       CONTINUE
39897             P(IEMP,5)=P(ISPL,5)
39898             P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
39899             IF(NLOOP.LE.2) GOTO 300
39900           ENDIF
39901         ENDIF
39902       ENDIF
39903
39904 C...If generalized thrust has not yet converged, continue iteration.
39905       IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
39906      &THEN
39907         TSAV=PSJT/PSS
39908         GOTO 310
39909       ENDIF
39910
39911 C...Reorder jets according to energy.
39912       DO 510 I=N+1,N+NJET
39913         DO 500 J=1,5
39914           V(I,J)=P(I,J)
39915   500   CONTINUE
39916   510 CONTINUE
39917       DO 540 INEW=N+1,N+NJET
39918         PEMAX=0D0
39919         DO 520 ITRY=N+1,N+NJET
39920           IF(V(ITRY,4).LE.PEMAX) GOTO 520
39921           IMAX=ITRY
39922           PEMAX=V(ITRY,4)
39923   520   CONTINUE
39924         K(INEW,1)=31
39925         K(INEW,2)=97
39926         K(INEW,3)=INEW-N
39927         K(INEW,4)=0
39928         DO 530 J=1,5
39929           P(INEW,J)=V(IMAX,J)
39930   530   CONTINUE
39931         V(IMAX,4)=-1D0
39932         K(IMAX,5)=INEW
39933   540 CONTINUE
39934
39935 C...Clean up particle-jet assignments and jet information.
39936       DO 550 I=N+NP+1,N+2*NP
39937         IORI=K(N+K(I,4),5)
39938         K(I,4)=IORI-N
39939         IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
39940         K(IORI,4)=K(IORI,4)+1
39941   550 CONTINUE
39942       IEMP=0
39943       PSJT=0D0
39944       DO 570 I=N+1,N+NJET
39945         K(I,5)=0
39946         PSJT=PSJT+P(I,5)
39947         P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
39948         DO 560 J=1,5
39949           V(I,J)=0D0
39950   560   CONTINUE
39951         IF(K(I,4).EQ.0) IEMP=I
39952   570 CONTINUE
39953
39954 C...Select storing option. Output variables. Check for failure.
39955       MSTU(61)=N+1
39956       MSTU(62)=NP
39957       MSTU(63)=NPRE
39958       PARU(61)=PS(5)
39959       PARU(62)=PSJT/PSS
39960       PARU(63)=SQRT(R2MIN)
39961       IF(NJET.LE.1) PARU(63)=0D0
39962       IF(IEMP.NE.0) THEN
39963         CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
39964         NJET=-1
39965       ENDIF
39966       IF(MSTU(43).LE.1) MSTU(3)=NJET
39967       IF(MSTU(43).GE.2) N=N+NJET
39968       NSAV=NJET
39969
39970       RETURN
39971       END
39972
39973 C*********************************************************************
39974
39975 *$ CREATE PYCELL.FOR
39976 *COPY PYCELL
39977 C...PYCELL
39978 C...Provides a simple way of jet finding in eta-phi-ET coordinates,
39979 C...as used for calorimeters at hadron colliders.
39980
39981       SUBROUTINE PYCELL(NJET)
39982
39983 C...Double precision and integer declarations.
39984       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39985       INTEGER PYK,PYCHGE,PYCOMP
39986 C...Commonblocks.
39987       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
39988       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39989       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39990       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
39991
39992 C...Loop over all particles. Find cell that was hit by given particle.
39993       PTLRAT=1D0/SINH(PARU(51))**2
39994       NP=0
39995       NC=N
39996       DO 110 I=1,N
39997         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
39998         IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
39999         IF(MSTU(41).GE.2) THEN
40000           KC=PYCOMP(K(I,2))
40001           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40002      &    KC.EQ.18) GOTO 110
40003           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40004      &    GOTO 110
40005         ENDIF
40006         NP=NP+1
40007         PT=SQRT(P(I,1)**2+P(I,2)**2)
40008         ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
40009         IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
40010      &  (ETA/PARU(51)+1D0))))
40011         PHI=PYANGL(P(I,1),P(I,2))
40012         IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
40013      &  (PHI/PARU(1)+1D0))))
40014         IETPH=MSTU(52)*IETA+IPHI
40015
40016 C...Add to cell already hit, or book new cell.
40017         DO 100 IC=N+1,NC
40018           IF(IETPH.EQ.K(IC,3)) THEN
40019             K(IC,4)=K(IC,4)+1
40020             P(IC,5)=P(IC,5)+PT
40021             GOTO 110
40022           ENDIF
40023   100   CONTINUE
40024         IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
40025           CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40026           NJET=-2
40027           RETURN
40028         ENDIF
40029         NC=NC+1
40030         K(NC,3)=IETPH
40031         K(NC,4)=1
40032         K(NC,5)=2
40033         P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
40034         P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
40035         P(NC,5)=PT
40036   110 CONTINUE
40037
40038 C...Smear true bin content by calorimeter resolution.
40039       IF(MSTU(53).GE.1) THEN
40040         DO 130 IC=N+1,NC
40041           PEI=P(IC,5)
40042           IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
40043   120     PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
40044      &    COS(PARU(2)*PYR(0))
40045           IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
40046           P(IC,5)=PEF
40047           IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
40048   130   CONTINUE
40049       ENDIF
40050
40051 C...Remove cells below threshold.
40052       IF(PARU(58).GT.0D0) THEN
40053         NCC=NC
40054         NC=N
40055         DO 140 IC=N+1,NCC
40056           IF(P(IC,5).GT.PARU(58)) THEN
40057             NC=NC+1
40058             K(NC,3)=K(IC,3)
40059             K(NC,4)=K(IC,4)
40060             K(NC,5)=K(IC,5)
40061             P(NC,1)=P(IC,1)
40062             P(NC,2)=P(IC,2)
40063             P(NC,5)=P(IC,5)
40064           ENDIF
40065   140   CONTINUE
40066       ENDIF
40067
40068 C...Find initiator cell: the one with highest pT of not yet used ones.
40069       NJ=NC
40070   150 ETMAX=0D0
40071       DO 160 IC=N+1,NC
40072         IF(K(IC,5).NE.2) GOTO 160
40073         IF(P(IC,5).LE.ETMAX) GOTO 160
40074         ICMAX=IC
40075         ETA=P(IC,1)
40076         PHI=P(IC,2)
40077         ETMAX=P(IC,5)
40078   160 CONTINUE
40079       IF(ETMAX.LT.PARU(52)) GOTO 220
40080       IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
40081         CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
40082         NJET=-2
40083         RETURN
40084       ENDIF
40085       K(ICMAX,5)=1
40086       NJ=NJ+1
40087       K(NJ,4)=0
40088       K(NJ,5)=1
40089       P(NJ,1)=ETA
40090       P(NJ,2)=PHI
40091       P(NJ,3)=0D0
40092       P(NJ,4)=0D0
40093       P(NJ,5)=0D0
40094
40095 C...Sum up unused cells within required distance of initiator.
40096       DO 170 IC=N+1,NC
40097         IF(K(IC,5).EQ.0) GOTO 170
40098         IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
40099         DPHIA=ABS(P(IC,2)-PHI)
40100         IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
40101         PHIC=P(IC,2)
40102         IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
40103         IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
40104         K(IC,5)=-K(IC,5)
40105         K(NJ,4)=K(NJ,4)+K(IC,4)
40106         P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
40107         P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
40108         P(NJ,5)=P(NJ,5)+P(IC,5)
40109   170 CONTINUE
40110
40111 C...Reject cluster below minimum ET, else accept.
40112       IF(P(NJ,5).LT.PARU(53)) THEN
40113         NJ=NJ-1
40114         DO 180 IC=N+1,NC
40115           IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
40116   180   CONTINUE
40117       ELSEIF(MSTU(54).LE.2) THEN
40118         P(NJ,3)=P(NJ,3)/P(NJ,5)
40119         P(NJ,4)=P(NJ,4)/P(NJ,5)
40120         IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
40121      &  P(NJ,4))
40122         DO 190 IC=N+1,NC
40123           IF(K(IC,5).LT.0) K(IC,5)=0
40124   190   CONTINUE
40125       ELSE
40126         DO 200 J=1,4
40127           P(NJ,J)=0D0
40128   200   CONTINUE
40129         DO 210 IC=N+1,NC
40130           IF(K(IC,5).GE.0) GOTO 210
40131           P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
40132           P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
40133           P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
40134           P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
40135           K(IC,5)=0
40136   210   CONTINUE
40137       ENDIF
40138       GOTO 150
40139
40140 C...Arrange clusters in falling ET sequence.
40141   220 DO 250 I=1,NJ-NC
40142         ETMAX=0D0
40143         DO 230 IJ=NC+1,NJ
40144           IF(K(IJ,5).EQ.0) GOTO 230
40145           IF(P(IJ,5).LT.ETMAX) GOTO 230
40146           IJMAX=IJ
40147           ETMAX=P(IJ,5)
40148   230   CONTINUE
40149         K(IJMAX,5)=0
40150         K(N+I,1)=31
40151         K(N+I,2)=98
40152         K(N+I,3)=I
40153         K(N+I,4)=K(IJMAX,4)
40154         K(N+I,5)=0
40155         DO 240 J=1,5
40156           P(N+I,J)=P(IJMAX,J)
40157           V(N+I,J)=0D0
40158   240   CONTINUE
40159   250 CONTINUE
40160       NJET=NJ-NC
40161
40162 C...Convert to massless or massive four-vectors.
40163       IF(MSTU(54).EQ.2) THEN
40164         DO 260 I=N+1,N+NJET
40165           ETA=P(I,3)
40166           P(I,1)=P(I,5)*COS(P(I,4))
40167           P(I,2)=P(I,5)*SIN(P(I,4))
40168           P(I,3)=P(I,5)*SINH(ETA)
40169           P(I,4)=P(I,5)*COSH(ETA)
40170           P(I,5)=0D0
40171   260   CONTINUE
40172       ELSEIF(MSTU(54).GE.3) THEN
40173         DO 270 I=N+1,N+NJET
40174           P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
40175   270   CONTINUE
40176       ENDIF
40177
40178 C...Information about storage.
40179       MSTU(61)=N+1
40180       MSTU(62)=NP
40181       MSTU(63)=NC-N
40182       IF(MSTU(43).LE.1) MSTU(3)=NJET
40183       IF(MSTU(43).GE.2) N=N+NJET
40184
40185       RETURN
40186       END
40187
40188 C*********************************************************************
40189
40190 *$ CREATE PYJMAS.FOR
40191 *COPY PYJMAS
40192 C...PYJMAS
40193 C...Determines, approximately, the two jet masses that minimize
40194 C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
40195
40196       SUBROUTINE PYJMAS(PMH,PML)
40197
40198 C...Double precision and integer declarations.
40199       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40200       INTEGER PYK,PYCHGE,PYCOMP
40201 C...Commonblocks.
40202       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40203       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40204       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40205       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40206 C...Local arrays.
40207       DIMENSION SM(3,3),SAX(3),PS(3,5)
40208
40209 C...Reset.
40210       NP=0
40211       DO 120 J1=1,3
40212         DO 100 J2=J1,3
40213           SM(J1,J2)=0D0
40214   100   CONTINUE
40215         DO 110 J2=1,4
40216           PS(J1,J2)=0D0
40217   110   CONTINUE
40218   120 CONTINUE
40219       PSS=0D0
40220       PIMASS=PMAS(PYCOMP(211),1)
40221
40222 C...Take copy of particles that are to be considered in mass analysis.
40223       DO 170 I=1,N
40224         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
40225         IF(MSTU(41).GE.2) THEN
40226           KC=PYCOMP(K(I,2))
40227           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40228      &    KC.EQ.18) GOTO 170
40229           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40230      &    GOTO 170
40231         ENDIF
40232         IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
40233           CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
40234           PMH=-2D0
40235           PML=-2D0
40236           RETURN
40237         ENDIF
40238         NP=NP+1
40239         DO 130 J=1,5
40240           P(N+NP,J)=P(I,J)
40241   130   CONTINUE
40242         IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
40243         IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
40244         P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40245
40246 C...Fill information in sphericity tensor and total momentum vector.
40247         DO 150 J1=1,3
40248           DO 140 J2=J1,3
40249             SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
40250   140     CONTINUE
40251   150   CONTINUE
40252         PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40253         DO 160 J=1,4
40254           PS(3,J)=PS(3,J)+P(N+NP,J)
40255   160   CONTINUE
40256   170 CONTINUE
40257
40258 C...Very low multiplicities (0 or 1) not considered.
40259       IF(NP.LE.1) THEN
40260         CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
40261         PMH=-1D0
40262         PML=-1D0
40263         RETURN
40264       ENDIF
40265       PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
40266      &PS(3,3)**2))
40267
40268 C...Find largest eigenvalue to matrix (third degree equation).
40269       DO 190 J1=1,3
40270         DO 180 J2=J1,3
40271           SM(J1,J2)=SM(J1,J2)/PSS
40272   180   CONTINUE
40273   190 CONTINUE
40274       SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
40275      &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
40276       SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
40277      &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
40278      &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
40279       SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
40280       SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
40281
40282 C...Find largest eigenvector by solving equation system.
40283       DO 210 J1=1,3
40284         SM(J1,J1)=SM(J1,J1)-SMA
40285         DO 200 J2=J1+1,3
40286           SM(J2,J1)=SM(J1,J2)
40287   200   CONTINUE
40288   210 CONTINUE
40289       SMAX=0D0
40290       DO 230 J1=1,3
40291         DO 220 J2=1,3
40292           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
40293           JA=J1
40294           JB=J2
40295           SMAX=ABS(SM(J1,J2))
40296   220   CONTINUE
40297   230 CONTINUE
40298       SMAX=0D0
40299       DO 250 J3=JA+1,JA+2
40300         J1=J3-3*((J3-1)/3)
40301         RL=SM(J1,JB)/SM(JA,JB)
40302         DO 240 J2=1,3
40303           SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
40304           IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
40305           JC=J1
40306           SMAX=ABS(SM(J1,J2))
40307   240   CONTINUE
40308   250 CONTINUE
40309       JB1=JB+1-3*(JB/3)
40310       JB2=JB+2-3*((JB+1)/3)
40311       SAX(JB1)=-SM(JC,JB2)
40312       SAX(JB2)=SM(JC,JB1)
40313       SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
40314
40315 C...Divide particles into two initial clusters by hemisphere.
40316       DO 270 I=N+1,N+NP
40317         PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
40318         IS=1
40319         IF(PSAX.LT.0D0) IS=2
40320         K(I,3)=IS
40321         DO 260 J=1,4
40322           PS(IS,J)=PS(IS,J)+P(I,J)
40323   260   CONTINUE
40324   270 CONTINUE
40325       PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
40326      &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
40327
40328 C...Reassign one particle at a time; find maximum decrease of m^2 sum.
40329   280 PMD=0D0
40330       IM=0
40331       DO 290 J=1,4
40332         PS(3,J)=PS(1,J)-PS(2,J)
40333   290 CONTINUE
40334       DO 300 I=N+1,N+NP
40335         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)
40336         IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
40337         IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
40338         IF(PMDI.LT.PMD) THEN
40339           PMD=PMDI
40340           IM=I
40341         ENDIF
40342   300 CONTINUE
40343
40344 C...Loop back if significant reduction in sum of m^2.
40345       IF(PMD.LT.-PARU(48)*PMS) THEN
40346         PMS=PMS+PMD
40347         IS=K(IM,3)
40348         DO 310 J=1,4
40349           PS(IS,J)=PS(IS,J)-P(IM,J)
40350           PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
40351   310   CONTINUE
40352         K(IM,3)=3-IS
40353         GOTO 280
40354       ENDIF
40355
40356 C...Final masses and output.
40357       MSTU(61)=N+1
40358       MSTU(62)=NP
40359       PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
40360       PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
40361       PMH=MAX(PS(1,5),PS(2,5))
40362       PML=MIN(PS(1,5),PS(2,5))
40363
40364       RETURN
40365       END
40366
40367 C*********************************************************************
40368
40369 *$ CREATE PYFOWO.FOR
40370 *COPY PYFOWO
40371 C...PYFOWO
40372 C...Calculates the first few Fox-Wolfram moments.
40373
40374       SUBROUTINE PYFOWO(H10,H20,H30,H40)
40375
40376 C...Double precision and integer declarations.
40377       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40378       INTEGER PYK,PYCHGE,PYCOMP
40379 C...Commonblocks.
40380       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40381       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40382       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40383       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
40384
40385 C...Copy momenta for particles and calculate H0.
40386       NP=0
40387       H0=0D0
40388       HD=0D0
40389       DO 110 I=1,N
40390         IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
40391         IF(MSTU(41).GE.2) THEN
40392           KC=PYCOMP(K(I,2))
40393           IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40394      &    KC.EQ.18) GOTO 110
40395           IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
40396      &    GOTO 110
40397         ENDIF
40398         IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
40399           CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
40400           H10=-1D0
40401           H20=-1D0
40402           H30=-1D0
40403           H40=-1D0
40404           RETURN
40405         ENDIF
40406         NP=NP+1
40407         DO 100 J=1,3
40408           P(N+NP,J)=P(I,J)
40409   100   CONTINUE
40410         P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
40411         H0=H0+P(N+NP,4)
40412         HD=HD+P(N+NP,4)**2
40413   110 CONTINUE
40414       H0=H0**2
40415
40416 C...Very low multiplicities (0 or 1) not considered.
40417       IF(NP.LE.1) THEN
40418         CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
40419         H10=-1D0
40420         H20=-1D0
40421         H30=-1D0
40422         H40=-1D0
40423         RETURN
40424       ENDIF
40425
40426 C...Calculate H1 - H4.
40427       H10=0D0
40428       H20=0D0
40429       H30=0D0
40430       H40=0D0
40431       DO 130 I1=N+1,N+NP
40432         DO 120 I2=I1+1,N+NP
40433           CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40434      &    (P(I1,4)*P(I2,4))
40435           H10=H10+P(I1,4)*P(I2,4)*CTHE
40436           H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
40437           H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
40438           H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
40439      &    0.375D0)
40440   120   CONTINUE
40441   130 CONTINUE
40442
40443 C...Calculate H1/H0 - H4/H0. Output.
40444       MSTU(61)=N+1
40445       MSTU(62)=NP
40446       H10=(HD+2D0*H10)/H0
40447       H20=(HD+2D0*H20)/H0
40448       H30=(HD+2D0*H30)/H0
40449       H40=(HD+2D0*H40)/H0
40450
40451       RETURN
40452       END
40453
40454 C*********************************************************************
40455
40456 *$ CREATE PYTABU.FOR
40457 *COPY PYTABU
40458 C...PYTABU
40459 C...Evaluates various properties of an event, with statistics
40460 C...accumulated during the course of the run and
40461 C...printed at the end.
40462
40463       SUBROUTINE PYTABU(MTABU)
40464
40465 C...Double precision and integer declarations.
40466       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40467       INTEGER PYK,PYCHGE,PYCOMP
40468 C...Commonblocks.
40469       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
40470       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40471       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40472       COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
40473       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
40474 C...Local arrays, character variables, saved variables and data.
40475       DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
40476      &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
40477      &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
40478      &KFDM(8),KFDC(200,0:8),NPDC(200)
40479       SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
40480      &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
40481      &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
40482       CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
40483       DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
40484      &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
40485      &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
40486      &NEVDC/0/,NKFDC/0/,NREDC/0/
40487
40488 C...Reset statistics on initial parton state.
40489       IF(MTABU.EQ.10) THEN
40490         NEVIS=0
40491         NKFIS=0
40492
40493 C...Identify and order flavour content of initial state.
40494       ELSEIF(MTABU.EQ.11) THEN
40495         NEVIS=NEVIS+1
40496         KFM1=2*IABS(MSTU(161))
40497         IF(MSTU(161).GT.0) KFM1=KFM1-1
40498         KFM2=2*IABS(MSTU(162))
40499         IF(MSTU(162).GT.0) KFM2=KFM2-1
40500         KFMN=MIN(KFM1,KFM2)
40501         KFMX=MAX(KFM1,KFM2)
40502         DO 100 I=1,NKFIS
40503           IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
40504             IKFIS=-I
40505             GOTO 110
40506           ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
40507      &      KFMX.LT.KFIS(I,2))) THEN
40508             IKFIS=I
40509             GOTO 110
40510           ENDIF
40511   100   CONTINUE
40512         IKFIS=NKFIS+1
40513   110   IF(IKFIS.LT.0) THEN
40514           IKFIS=-IKFIS
40515         ELSE
40516           IF(NKFIS.GE.100) RETURN
40517           DO 130 I=NKFIS,IKFIS,-1
40518             KFIS(I+1,1)=KFIS(I,1)
40519             KFIS(I+1,2)=KFIS(I,2)
40520             DO 120 J=0,10
40521               NPIS(I+1,J)=NPIS(I,J)
40522   120       CONTINUE
40523   130     CONTINUE
40524           NKFIS=NKFIS+1
40525           KFIS(IKFIS,1)=KFMN
40526           KFIS(IKFIS,2)=KFMX
40527           DO 140 J=0,10
40528             NPIS(IKFIS,J)=0
40529   140     CONTINUE
40530         ENDIF
40531         NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
40532
40533 C...Count number of partons in initial state.
40534         NP=0
40535         DO 160 I=1,N
40536           IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
40537           ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
40538           ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
40539      &      THEN
40540           ELSE
40541             IM=I
40542   150       IM=K(IM,3)
40543             IF(IM.LE.0.OR.IM.GT.N) THEN
40544               NP=NP+1
40545             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40546               NP=NP+1
40547             ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
40548             ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
40549      &        .NE.0) THEN
40550             ELSE
40551               GOTO 150
40552             ENDIF
40553           ENDIF
40554   160   CONTINUE
40555         NPCO=MAX(NP,1)
40556         IF(NP.GE.6) NPCO=6
40557         IF(NP.GE.8) NPCO=7
40558         IF(NP.GE.11) NPCO=8
40559         IF(NP.GE.16) NPCO=9
40560         IF(NP.GE.26) NPCO=10
40561         NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
40562         MSTU(62)=NP
40563
40564 C...Write statistics on initial parton state.
40565       ELSEIF(MTABU.EQ.12) THEN
40566         FAC=1D0/MAX(1,NEVIS)
40567         WRITE(MSTU(11),5000) NEVIS
40568         DO 170 I=1,NKFIS
40569           KFMN=KFIS(I,1)
40570           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40571           KFM1=(KFMN+1)/2
40572           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40573           CALL PYNAME(KFM1,CHAU)
40574           CHIS(1)=CHAU(1:12)
40575           IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
40576           KFMX=KFIS(I,2)
40577           IF(KFIS(I,1).EQ.0) KFMX=0
40578           KFM2=(KFMX+1)/2
40579           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40580           CALL PYNAME(KFM2,CHAU)
40581           CHIS(2)=CHAU(1:12)
40582           IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
40583           WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
40584      &    (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
40585   170   CONTINUE
40586
40587 C...Copy statistics on initial parton state into /PYJETS/.
40588       ELSEIF(MTABU.EQ.13) THEN
40589         FAC=1D0/MAX(1,NEVIS)
40590         DO 190 I=1,NKFIS
40591           KFMN=KFIS(I,1)
40592           IF(KFMN.EQ.0) KFMN=KFIS(I,2)
40593           KFM1=(KFMN+1)/2
40594           IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
40595           KFMX=KFIS(I,2)
40596           IF(KFIS(I,1).EQ.0) KFMX=0
40597           KFM2=(KFMX+1)/2
40598           IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
40599           K(I,1)=32
40600           K(I,2)=99
40601           K(I,3)=KFM1
40602           K(I,4)=KFM2
40603           K(I,5)=NPIS(I,0)
40604           DO 180 J=1,5
40605             P(I,J)=FAC*NPIS(I,J)
40606             V(I,J)=FAC*NPIS(I,J+5)
40607   180     CONTINUE
40608   190   CONTINUE
40609         N=NKFIS
40610         DO 200 J=1,5
40611           K(N+1,J)=0
40612           P(N+1,J)=0D0
40613           V(N+1,J)=0D0
40614   200   CONTINUE
40615         K(N+1,1)=32
40616         K(N+1,2)=99
40617         K(N+1,5)=NEVIS
40618         MSTU(3)=1
40619
40620 C...Reset statistics on number of particles/partons.
40621       ELSEIF(MTABU.EQ.20) THEN
40622         NEVFS=0
40623         NPRFS=0
40624         NFIFS=0
40625         NCHFS=0
40626         NKFFS=0
40627
40628 C...Identify whether particle/parton is primary or not.
40629       ELSEIF(MTABU.EQ.21) THEN
40630         NEVFS=NEVFS+1
40631         MSTU(62)=0
40632         DO 260 I=1,N
40633           IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
40634           MSTU(62)=MSTU(62)+1
40635           KC=PYCOMP(K(I,2))
40636           MPRI=0
40637           IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
40638             MPRI=1
40639           ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
40640             MPRI=1
40641           ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
40642             MPRI=1
40643           ELSEIF(KC.EQ.0) THEN
40644           ELSEIF(K(K(I,3),1).EQ.13) THEN
40645             IM=K(K(I,3),3)
40646             IF(IM.LE.0.OR.IM.GT.N) THEN
40647               MPRI=1
40648             ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
40649               MPRI=1
40650             ENDIF
40651           ELSEIF(KCHG(KC,2).EQ.0) THEN
40652             KCM=PYCOMP(K(K(I,3),2))
40653             IF(KCM.NE.0) THEN
40654               IF(KCHG(KCM,2).NE.0) MPRI=1
40655             ENDIF
40656           ENDIF
40657           IF(KC.NE.0.AND.MPRI.EQ.1) THEN
40658             IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
40659           ENDIF
40660           IF(K(I,1).LE.10) THEN
40661             NFIFS=NFIFS+1
40662             IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
40663           ENDIF
40664
40665 C...Fill statistics on number of particles/partons in event.
40666           KFA=IABS(K(I,2))
40667           KFS=3-ISIGN(1,K(I,2))-MPRI
40668           DO 210 IP=1,NKFFS
40669             IF(KFA.EQ.KFFS(IP)) THEN
40670               IKFFS=-IP
40671               GOTO 220
40672             ELSEIF(KFA.LT.KFFS(IP)) THEN
40673               IKFFS=IP
40674               GOTO 220
40675             ENDIF
40676   210     CONTINUE
40677           IKFFS=NKFFS+1
40678   220     IF(IKFFS.LT.0) THEN
40679             IKFFS=-IKFFS
40680           ELSE
40681             IF(NKFFS.GE.400) RETURN
40682             DO 240 IP=NKFFS,IKFFS,-1
40683               KFFS(IP+1)=KFFS(IP)
40684               DO 230 J=1,4
40685                 NPFS(IP+1,J)=NPFS(IP,J)
40686   230         CONTINUE
40687   240       CONTINUE
40688             NKFFS=NKFFS+1
40689             KFFS(IKFFS)=KFA
40690             DO 250 J=1,4
40691               NPFS(IKFFS,J)=0
40692   250       CONTINUE
40693           ENDIF
40694           NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
40695   260   CONTINUE
40696
40697 C...Write statistics on particle/parton composition of events.
40698       ELSEIF(MTABU.EQ.22) THEN
40699         FAC=1D0/MAX(1,NEVFS)
40700         WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
40701         DO 270 I=1,NKFFS
40702           CALL PYNAME(KFFS(I),CHAU)
40703           KC=PYCOMP(KFFS(I))
40704           MDCYF=0
40705           IF(KC.NE.0) MDCYF=MDCY(KC,1)
40706           WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
40707      &    FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
40708   270   CONTINUE
40709
40710 C...Copy particle/parton composition information into /PYJETS/.
40711       ELSEIF(MTABU.EQ.23) THEN
40712         FAC=1D0/MAX(1,NEVFS)
40713         DO 290 I=1,NKFFS
40714           K(I,1)=32
40715           K(I,2)=99
40716           K(I,3)=KFFS(I)
40717           K(I,4)=0
40718           K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
40719           DO 280 J=1,4
40720             P(I,J)=FAC*NPFS(I,J)
40721             V(I,J)=0D0
40722   280     CONTINUE
40723           P(I,5)=FAC*K(I,5)
40724           V(I,5)=0D0
40725   290   CONTINUE
40726         N=NKFFS
40727         DO 300 J=1,5
40728           K(N+1,J)=0
40729           P(N+1,J)=0D0
40730           V(N+1,J)=0D0
40731   300   CONTINUE
40732         K(N+1,1)=32
40733         K(N+1,2)=99
40734         K(N+1,5)=NEVFS
40735         P(N+1,1)=FAC*NPRFS
40736         P(N+1,2)=FAC*NFIFS
40737         P(N+1,3)=FAC*NCHFS
40738         MSTU(3)=1
40739
40740 C...Reset factorial moments statistics.
40741       ELSEIF(MTABU.EQ.30) THEN
40742         NEVFM=0
40743         NMUFM=0
40744         DO 330 IM=1,3
40745           DO 320 IB=1,10
40746             DO 310 IP=1,4
40747               FM1FM(IM,IB,IP)=0D0
40748               FM2FM(IM,IB,IP)=0D0
40749   310       CONTINUE
40750   320     CONTINUE
40751   330   CONTINUE
40752
40753 C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
40754       ELSEIF(MTABU.EQ.31) THEN
40755         NEVFM=NEVFM+1
40756         NLOW=N+MSTU(3)
40757         NUPP=NLOW
40758         DO 410 I=1,N
40759           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
40760           IF(MSTU(41).GE.2) THEN
40761             KC=PYCOMP(K(I,2))
40762             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40763      &      KC.EQ.18) GOTO 410
40764             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40765      &      PYCHGE(K(I,2)).EQ.0) GOTO 410
40766           ENDIF
40767           PMR=0D0
40768           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40769           IF(MSTU(42).GE.2) PMR=P(I,5)
40770           PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
40771           YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
40772      &    1D20)),P(I,3))
40773           IF(ABS(YETA).GT.PARU(57)) GOTO 410
40774           PHI=PYANGL(P(I,1),P(I,2))
40775           IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
40776           IYETA=MAX(0,MIN(511,IYETA))
40777           IPHI=512D0*(PHI+PARU(1))/PARU(2)
40778           IPHI=MAX(0,MIN(511,IPHI))
40779           IYEP=0
40780           DO 340 IB=0,9
40781             IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
40782   340     CONTINUE
40783
40784 C...Order particles in (pseudo)rapidity and/or azimuth.
40785           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40786             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40787             RETURN
40788           ENDIF
40789           NUPP=NUPP+1
40790           IF(NUPP.EQ.NLOW+1) THEN
40791             K(NUPP,1)=IYETA
40792             K(NUPP,2)=IPHI
40793             K(NUPP,3)=IYEP
40794           ELSE
40795             DO 350 I1=NUPP-1,NLOW+1,-1
40796               IF(IYETA.GE.K(I1,1)) GOTO 360
40797               K(I1+1,1)=K(I1,1)
40798   350       CONTINUE
40799   360       K(I1+1,1)=IYETA
40800             DO 370 I1=NUPP-1,NLOW+1,-1
40801               IF(IPHI.GE.K(I1,2)) GOTO 380
40802               K(I1+1,2)=K(I1,2)
40803   370       CONTINUE
40804   380       K(I1+1,2)=IPHI
40805             DO 390 I1=NUPP-1,NLOW+1,-1
40806               IF(IYEP.GE.K(I1,3)) GOTO 400
40807               K(I1+1,3)=K(I1,3)
40808   390       CONTINUE
40809   400       K(I1+1,3)=IYEP
40810           ENDIF
40811   410   CONTINUE
40812         K(NUPP+1,1)=2**10
40813         K(NUPP+1,2)=2**10
40814         K(NUPP+1,3)=4**10
40815
40816 C...Calculate sum of factorial moments in event.
40817         DO 480 IM=1,3
40818           DO 430 IB=1,10
40819             DO 420 IP=1,4
40820               FEVFM(IB,IP)=0D0
40821   420       CONTINUE
40822   430     CONTINUE
40823           DO 450 IB=1,10
40824             IF(IM.LE.2) IBIN=2**(10-IB)
40825             IF(IM.EQ.3) IBIN=4**(10-IB)
40826             IAGR=K(NLOW+1,IM)/IBIN
40827             NAGR=1
40828             DO 440 I=NLOW+2,NUPP+1
40829               ICUT=K(I,IM)/IBIN
40830               IF(ICUT.EQ.IAGR) THEN
40831                 NAGR=NAGR+1
40832               ELSE
40833                 IF(NAGR.EQ.1) THEN
40834                 ELSEIF(NAGR.EQ.2) THEN
40835                   FEVFM(IB,1)=FEVFM(IB,1)+2D0
40836                 ELSEIF(NAGR.EQ.3) THEN
40837                   FEVFM(IB,1)=FEVFM(IB,1)+6D0
40838                   FEVFM(IB,2)=FEVFM(IB,2)+6D0
40839                 ELSEIF(NAGR.EQ.4) THEN
40840                   FEVFM(IB,1)=FEVFM(IB,1)+12D0
40841                   FEVFM(IB,2)=FEVFM(IB,2)+24D0
40842                   FEVFM(IB,3)=FEVFM(IB,3)+24D0
40843                 ELSE
40844                   FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
40845                   FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
40846                   FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40847      &            (NAGR-3D0)
40848                   FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
40849      &            (NAGR-3D0)*(NAGR-4D0)
40850                 ENDIF
40851                 IAGR=ICUT
40852                 NAGR=1
40853               ENDIF
40854   440       CONTINUE
40855   450     CONTINUE
40856
40857 C...Add results to total statistics.
40858           DO 470 IB=10,1,-1
40859             DO 460 IP=1,4
40860               IF(FEVFM(1,IP).LT.0.5D0) THEN
40861                 FEVFM(IB,IP)=0D0
40862               ELSEIF(IM.LE.2) THEN
40863                 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40864               ELSE
40865                 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
40866               ENDIF
40867               FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
40868               FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
40869   460       CONTINUE
40870   470     CONTINUE
40871   480   CONTINUE
40872         NMUFM=NMUFM+(NUPP-NLOW)
40873         MSTU(62)=NUPP-NLOW
40874
40875 C...Write accumulated statistics on factorial moments.
40876       ELSEIF(MTABU.EQ.32) THEN
40877         FAC=1D0/MAX(1,NEVFM)
40878         IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
40879         IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
40880         IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y  '
40881         DO 510 IM=1,3
40882           WRITE(MSTU(11),5500)
40883           DO 500 IB=1,10
40884             BYETA=2D0*PARU(57)
40885             IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
40886             BPHI=PARU(2)
40887             IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
40888             IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
40889             IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
40890             DO 490 IP=1,4
40891               FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
40892               FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40893      &        FMOMA(IP)**2)))
40894   490       CONTINUE
40895             WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
40896      &      IP=1,4)
40897   500     CONTINUE
40898   510   CONTINUE
40899
40900 C...Copy statistics on factorial moments into /PYJETS/.
40901       ELSEIF(MTABU.EQ.33) THEN
40902         FAC=1D0/MAX(1,NEVFM)
40903         DO 540 IM=1,3
40904           DO 530 IB=1,10
40905             I=10*(IM-1)+IB
40906             K(I,1)=32
40907             K(I,2)=99
40908             K(I,3)=1
40909             IF(IM.NE.2) K(I,3)=2**(IB-1)
40910             K(I,4)=1
40911             IF(IM.NE.1) K(I,4)=2**(IB-1)
40912             K(I,5)=0
40913             P(I,1)=2D0*PARU(57)/K(I,3)
40914             V(I,1)=PARU(2)/K(I,4)
40915             DO 520 IP=1,4
40916               P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
40917               V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
40918      &        P(I,IP+1)**2)))
40919   520       CONTINUE
40920   530     CONTINUE
40921   540   CONTINUE
40922         N=30
40923         DO 550 J=1,5
40924           K(N+1,J)=0
40925           P(N+1,J)=0D0
40926           V(N+1,J)=0D0
40927   550   CONTINUE
40928         K(N+1,1)=32
40929         K(N+1,2)=99
40930         K(N+1,5)=NEVFM
40931         MSTU(3)=1
40932
40933 C...Reset statistics on Energy-Energy Correlation.
40934       ELSEIF(MTABU.EQ.40) THEN
40935         NEVEE=0
40936         DO 560 J=1,25
40937           FE1EC(J)=0D0
40938           FE2EC(J)=0D0
40939           FE1EC(51-J)=0D0
40940           FE2EC(51-J)=0D0
40941           FE1EA(J)=0D0
40942           FE2EA(J)=0D0
40943   560   CONTINUE
40944
40945 C...Find particles to include, with proper assumed mass.
40946       ELSEIF(MTABU.EQ.41) THEN
40947         NEVEE=NEVEE+1
40948         NLOW=N+MSTU(3)
40949         NUPP=NLOW
40950         ECM=0D0
40951         DO 570 I=1,N
40952           IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
40953           IF(MSTU(41).GE.2) THEN
40954             KC=PYCOMP(K(I,2))
40955             IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
40956      &      KC.EQ.18) GOTO 570
40957             IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
40958      &      PYCHGE(K(I,2)).EQ.0) GOTO 570
40959           ENDIF
40960           PMR=0D0
40961           IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
40962           IF(MSTU(42).GE.2) PMR=P(I,5)
40963           IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
40964             CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
40965             RETURN
40966           ENDIF
40967           NUPP=NUPP+1
40968           P(NUPP,1)=P(I,1)
40969           P(NUPP,2)=P(I,2)
40970           P(NUPP,3)=P(I,3)
40971           P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
40972           P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
40973           ECM=ECM+P(NUPP,4)
40974   570   CONTINUE
40975         IF(NUPP.EQ.NLOW) RETURN
40976
40977 C...Analyze Energy-Energy Correlation in event.
40978         FAC=(2D0/ECM**2)*50D0/PARU(1)
40979         DO 580 J=1,50
40980           FEVEE(J)=0D0
40981   580   CONTINUE
40982         DO 600 I1=NLOW+2,NUPP
40983           DO 590 I2=NLOW+1,I1-1
40984             CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
40985      &      (P(I1,5)*P(I2,5))
40986             THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
40987             ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
40988             FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
40989   590     CONTINUE
40990   600   CONTINUE
40991         DO 610 J=1,25
40992           FE1EC(J)=FE1EC(J)+FEVEE(J)
40993           FE2EC(J)=FE2EC(J)+FEVEE(J)**2
40994           FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
40995           FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
40996           FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
40997           FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
40998   610   CONTINUE
40999         MSTU(62)=NUPP-NLOW
41000
41001 C...Write statistics on Energy-Energy Correlation.
41002       ELSEIF(MTABU.EQ.42) THEN
41003         FAC=1D0/MAX(1,NEVEE)
41004         WRITE(MSTU(11),5700) NEVEE
41005         DO 620 J=1,25
41006           FEEC1=FAC*FE1EC(J)
41007           FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
41008           FEEC2=FAC*FE1EC(51-J)
41009           FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
41010           FEECA=FAC*FE1EA(J)
41011           FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
41012           WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
41013      &    FEEC2,FEES2,FEECA,FEESA
41014   620   CONTINUE
41015
41016 C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
41017       ELSEIF(MTABU.EQ.43) THEN
41018         FAC=1D0/MAX(1,NEVEE)
41019         DO 630 I=1,25
41020           K(I,1)=32
41021           K(I,2)=99
41022           K(I,3)=0
41023           K(I,4)=0
41024           K(I,5)=0
41025           P(I,1)=FAC*FE1EC(I)
41026           V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
41027           P(I,2)=FAC*FE1EC(51-I)
41028           V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
41029           P(I,3)=FAC*FE1EA(I)
41030           V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
41031           P(I,4)=PARU(1)*(I-1)/50D0
41032           P(I,5)=PARU(1)*I/50D0
41033           V(I,4)=3.6D0*(I-1)
41034           V(I,5)=3.6D0*I
41035   630   CONTINUE
41036         N=25
41037         DO 640 J=1,5
41038           K(N+1,J)=0
41039           P(N+1,J)=0D0
41040           V(N+1,J)=0D0
41041   640   CONTINUE
41042         K(N+1,1)=32
41043         K(N+1,2)=99
41044         K(N+1,5)=NEVEE
41045         MSTU(3)=1
41046
41047 C...Reset statistics on decay channels.
41048       ELSEIF(MTABU.EQ.50) THEN
41049         NEVDC=0
41050         NKFDC=0
41051         NREDC=0
41052
41053 C...Identify and order flavour content of final state.
41054       ELSEIF(MTABU.EQ.51) THEN
41055         NEVDC=NEVDC+1
41056         NDS=0
41057         DO 670 I=1,N
41058           IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
41059           NDS=NDS+1
41060           IF(NDS.GT.8) THEN
41061             NREDC=NREDC+1
41062             RETURN
41063           ENDIF
41064           KFM=2*IABS(K(I,2))
41065           IF(K(I,2).LT.0) KFM=KFM-1
41066           DO 650 IDS=NDS-1,1,-1
41067             IIN=IDS+1
41068             IF(KFM.LT.KFDM(IDS)) GOTO 660
41069             KFDM(IDS+1)=KFDM(IDS)
41070   650     CONTINUE
41071           IIN=1
41072   660     KFDM(IIN)=KFM
41073   670   CONTINUE
41074
41075 C...Find whether old or new final state.
41076         DO 690 IDC=1,NKFDC
41077           IF(NDS.LT.KFDC(IDC,0)) THEN
41078             IKFDC=IDC
41079             GOTO 700
41080           ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
41081             DO 680 I=1,NDS
41082               IF(KFDM(I).LT.KFDC(IDC,I)) THEN
41083                 IKFDC=IDC
41084                 GOTO 700
41085               ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
41086                 GOTO 690
41087               ENDIF
41088   680       CONTINUE
41089             IKFDC=-IDC
41090             GOTO 700
41091           ENDIF
41092   690   CONTINUE
41093         IKFDC=NKFDC+1
41094   700   IF(IKFDC.LT.0) THEN
41095           IKFDC=-IKFDC
41096         ELSEIF(NKFDC.GE.200) THEN
41097           NREDC=NREDC+1
41098           RETURN
41099         ELSE
41100           DO 720 IDC=NKFDC,IKFDC,-1
41101             NPDC(IDC+1)=NPDC(IDC)
41102             DO 710 I=0,8
41103               KFDC(IDC+1,I)=KFDC(IDC,I)
41104   710       CONTINUE
41105   720     CONTINUE
41106           NKFDC=NKFDC+1
41107           KFDC(IKFDC,0)=NDS
41108           DO 730 I=1,NDS
41109             KFDC(IKFDC,I)=KFDM(I)
41110   730     CONTINUE
41111           NPDC(IKFDC)=0
41112         ENDIF
41113         NPDC(IKFDC)=NPDC(IKFDC)+1
41114
41115 C...Write statistics on decay channels.
41116       ELSEIF(MTABU.EQ.52) THEN
41117         FAC=1D0/MAX(1,NEVDC)
41118         WRITE(MSTU(11),5900) NEVDC
41119         DO 750 IDC=1,NKFDC
41120           DO 740 I=1,KFDC(IDC,0)
41121             KFM=KFDC(IDC,I)
41122             KF=(KFM+1)/2
41123             IF(2*KF.NE.KFM) KF=-KF
41124             CALL PYNAME(KF,CHAU)
41125             CHDC(I)=CHAU(1:12)
41126             IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
41127   740     CONTINUE
41128           WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
41129   750   CONTINUE
41130         IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
41131
41132 C...Copy statistics on decay channels into /PYJETS/.
41133       ELSEIF(MTABU.EQ.53) THEN
41134         FAC=1D0/MAX(1,NEVDC)
41135         DO 780 IDC=1,NKFDC
41136           K(IDC,1)=32
41137           K(IDC,2)=99
41138           K(IDC,3)=0
41139           K(IDC,4)=0
41140           K(IDC,5)=KFDC(IDC,0)
41141           DO 760 J=1,5
41142             P(IDC,J)=0D0
41143             V(IDC,J)=0D0
41144   760     CONTINUE
41145           DO 770 I=1,KFDC(IDC,0)
41146             KFM=KFDC(IDC,I)
41147             KF=(KFM+1)/2
41148             IF(2*KF.NE.KFM) KF=-KF
41149             IF(I.LE.5) P(IDC,I)=KF
41150             IF(I.GE.6) V(IDC,I-5)=KF
41151   770     CONTINUE
41152           V(IDC,5)=FAC*NPDC(IDC)
41153   780   CONTINUE
41154         N=NKFDC
41155         DO 790 J=1,5
41156           K(N+1,J)=0
41157           P(N+1,J)=0D0
41158           V(N+1,J)=0D0
41159   790   CONTINUE
41160         K(N+1,1)=32
41161         K(N+1,2)=99
41162         K(N+1,5)=NEVDC
41163         V(N+1,5)=FAC*NREDC
41164         MSTU(3)=1
41165       ENDIF
41166
41167 C...Format statements for output on unit MSTU(11) (default 6).
41168  5000 FORMAT(///20X,'Event statistics - initial state'/
41169      &20X,'based on an analysis of ',I6,' events'//
41170      &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
41171      &'according to fragmenting system multiplicity'/
41172      &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
41173      &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
41174  5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
41175  5200 FORMAT(///20X,'Event statistics - final state'/
41176      &20X,'based on an analysis of ',I7,' events'//
41177      &5X,'Mean primary multiplicity =',F10.4/
41178      &5X,'Mean final   multiplicity =',F10.4/
41179      &5X,'Mean charged multiplicity =',F10.4//
41180      &5X,'Number of particles produced per event (directly and via ',
41181      &'decays/branchings)'/
41182      &8X,'KF    Particle/jet  MDCY',10X,'Particles',13X,'Antiparticles',
41183      &8X,'Total'/35X,'prim        seco        prim        seco'/)
41184  5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
41185  5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
41186      &20X,'based on an analysis of ',I6,' events'//
41187      &3X,'delta-',A3,' delta-phi     <n>/bin',10X,'<F2>',18X,'<F3>',
41188      &18X,'<F4>',18X,'<F5>'/35X,4('     value     error  '))
41189  5500 FORMAT(10X)
41190  5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
41191  5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
41192      &20X,'based on an analysis of ',I6,' events'//
41193      &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
41194      &'EECA(theta)'/2X,'in degrees ',3('      value    error')/)
41195  5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
41196  5900 FORMAT(///20X,'Decay channel analysis - final state'/
41197      &20X,'based on an analysis of ',I6,' events'//
41198      &2X,'Probability',10X,'Complete final state'/)
41199  6000 FORMAT(2X,F9.5,5X,8(A12,1X))
41200  6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
41201      &'or table overflow)')
41202
41203       RETURN
41204       END
41205
41206 C*********************************************************************
41207
41208 *$ CREATE PYEEVT.FOR
41209 *COPY PYEEVT
41210 C...PYEEVT
41211 C...Handles the generation of an e+e- annihilation jet event.
41212
41213       SUBROUTINE PYEEVT(KFL,ECM)
41214 C...Double precision and integer declarations.
41215       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41216       INTEGER PYK,PYCHGE,PYCOMP
41217 C...Commonblocks.
41218       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
41219       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41220       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41221       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
41222
41223 C...Check input parameters.
41224       IF(MSTU(12).GE.1) CALL PYLIST(0)
41225       IF(KFL.LT.0.OR.KFL.GT.8) THEN
41226         CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
41227         IF(MSTU(21).GE.1) RETURN
41228       ENDIF
41229       IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
41230       IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
41231       IF(ECM.LT.ECMMIN) THEN
41232         CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
41233         IF(MSTU(21).GE.1) RETURN
41234       ENDIF
41235
41236 C...Check consistency of MSTJ options set.
41237       IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
41238         CALL PYERRM(6,
41239      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
41240         MSTJ(110)=1
41241       ENDIF
41242       IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
41243         CALL PYERRM(6,
41244      &  '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
41245         MSTJ(111)=0
41246       ENDIF
41247
41248 C...Initialize alpha_strong and total cross-section.
41249       MSTU(111)=MSTJ(108)
41250       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
41251      &MSTU(111)=1
41252       PARU(112)=PARJ(121)
41253       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
41254       IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
41255      &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
41256      &XTOT)
41257       IF(MSTJ(116).GE.3) MSTJ(116)=1
41258       PARJ(171)=0D0
41259
41260 C...Add initial e+e- to event record (documentation only).
41261       NTRY=0
41262   100 NTRY=NTRY+1
41263       IF(NTRY.GT.100) THEN
41264         CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
41265         RETURN
41266       ENDIF
41267       MSTU(24)=0
41268       NC=0
41269       IF(MSTJ(115).GE.2) THEN
41270         NC=NC+2
41271         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
41272         K(NC-1,1)=21
41273         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
41274         K(NC,1)=21
41275       ENDIF
41276
41277 C...Radiative photon (in initial state).
41278       MK=0
41279       ECMC=ECM
41280       IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
41281      &THEK,PHIK,ALPK)
41282       IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
41283       IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
41284         NC=NC+1
41285         CALL PY1ENT(NC,22,PAK,THEK,PHIK)
41286         K(NC,3)=MIN(MSTJ(115)/2,1)
41287       ENDIF
41288
41289 C...Virtual exchange boson (gamma or Z0).
41290       IF(MSTJ(115).GE.3) THEN
41291         NC=NC+1
41292         KF=22
41293         IF(MSTJ(102).EQ.2) KF=23
41294         MSTU10=MSTU(10)
41295         MSTU(10)=1
41296         P(NC,5)=ECMC
41297         CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
41298         K(NC,1)=21
41299         K(NC,3)=1
41300         MSTU(10)=MSTU10
41301       ENDIF
41302
41303 C...Choice of flavour and jet configuration.
41304       CALL PYXKFL(KFL,ECM,ECMC,KFLC)
41305       IF(KFLC.EQ.0) GOTO 100
41306       CALL PYXJET(ECMC,NJET,CUT)
41307       KFLN=21
41308       IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
41309      &X12,X14)
41310       IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
41311       IF(NJET.EQ.2) MSTJ(120)=1
41312
41313 C...Fill jet configuration and origin.
41314       IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
41315       IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
41316      &ECMC)
41317       IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
41318       IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
41319      &-KFLC,ECMC,X1,X2,X4,X12,X14)
41320       IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
41321      &-KFLC,ECMC,X1,X2,X4,X12,X14)
41322       IF(MSTU(24).NE.0) GOTO 100
41323       DO 110 IP=NC+1,N
41324         K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
41325   110 CONTINUE
41326
41327 C...Angular orientation according to matrix element.
41328       IF(MSTJ(106).EQ.1) THEN
41329         CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
41330         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
41331         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
41332       ENDIF
41333
41334 C...Rotation and boost from radiative photon.
41335       IF(MK.EQ.1) THEN
41336         DBEK=-PAK/(ECM-PAK)
41337         NMIN=NC+1-MSTJ(115)/3
41338         CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
41339         CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
41340         CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
41341       ENDIF
41342
41343 C...Generate parton shower. Rearrange along strings and check.
41344       IF(MSTJ(101).EQ.5) THEN
41345         CALL PYSHOW(N-1,N,ECMC)
41346         MSTJ14=MSTJ(14)
41347         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
41348         IF(MSTJ(105).GE.0) MSTU(28)=0
41349         CALL PYPREP(0)
41350         MSTJ(14)=MSTJ14
41351         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
41352       ENDIF
41353
41354 C...Fragmentation/decay generation. Information for PYTABU.
41355       IF(MSTJ(105).EQ.1) CALL PYEXEC
41356       MSTU(161)=KFLC
41357       MSTU(162)=-KFLC
41358
41359       RETURN
41360       END
41361
41362 C*********************************************************************
41363
41364 *$ CREATE PYXTEE.FOR
41365 *COPY PYXTEE
41366 C...PYXTEE
41367 C...Calculates total cross-section, including initial state
41368 C...radiation effects.
41369
41370       SUBROUTINE PYXTEE(KFL,ECM,XTOT)
41371
41372 C...Double precision and integer declarations.
41373       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41374       INTEGER PYK,PYCHGE,PYCOMP
41375 C...Commonblocks.
41376       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41377       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41378       SAVE /PYDAT1/,/PYDAT2/
41379
41380 C...Status, (optimized) Q^2 scale, alpha_strong.
41381       PARJ(151)=ECM
41382       MSTJ(119)=10*MSTJ(102)+KFL
41383       IF(MSTJ(111).EQ.0) THEN
41384         Q2R=ECM**2
41385       ELSEIF(MSTU(111).EQ.0) THEN
41386         PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41387      &  ((33D0-2D0*MSTU(112))*PARU(111)))))
41388         Q2R=PARJ(168)*ECM**2
41389       ELSE
41390         PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41391      &  (2D0*PARU(112)/ECM)**2))
41392         Q2R=PARJ(168)*ECM**2
41393       ENDIF
41394       ALSPI=PYALPS(Q2R)/PARU(1)
41395
41396 C...QCD corrections factor in R.
41397       IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
41398         RQCD=1D0
41399       ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
41400         RQCD=1D0+ALSPI
41401       ELSEIF(MSTJ(109).EQ.0) THEN
41402         RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41403         IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
41404      &  LOG(PARJ(168))*ALSPI**2)
41405       ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
41406         RQCD=1D0+(3D0/4D0)*ALSPI
41407       ELSE
41408         RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
41409       ENDIF
41410
41411 C...Calculate Z0 width if default value not acceptable.
41412       IF(MSTJ(102).GE.3) THEN
41413         RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
41414      &  (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
41415         DO 100 KFLC=5,6
41416           VQ=1D0
41417           IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
41418      &    (2D0*PYMASS(KFLC)/ ECM)**2))
41419           IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
41420           IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
41421           RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
41422   100   CONTINUE
41423         PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
41424      &  (1D0-PARU(102)))
41425       ENDIF
41426
41427 C...Calculate propagator and related constants for QFD case.
41428       POLL=1D0-PARJ(131)*PARJ(132)
41429       IF(MSTJ(102).GE.2) THEN
41430         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41431         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41432         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
41433         VE=4D0*PARU(102)-1D0
41434         SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
41435         SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41436         HF1I=SFI*SF1I
41437         HF1W=SFW*SF1W
41438       ENDIF
41439
41440 C...Loop over different flavours: charge, velocity.
41441       RTOT=0D0
41442       RQQ=0D0
41443       RQV=0D0
41444       RVA=0D0
41445       DO 110 KFLC=1,MAX(MSTJ(104),KFL)
41446         IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
41447         MSTJ(93)=1
41448         PMQ=PYMASS(KFLC)
41449         IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
41450         QF=KCHG(KFLC,1)/3D0
41451         VQ=1D0
41452         IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
41453
41454 C...Calculate R and sum of charges for QED or QFD case.
41455         RQQ=RQQ+3D0*QF**2*POLL
41456         IF(MSTJ(102).LE.1) THEN
41457           RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
41458         ELSE
41459           VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41460           RQV=RQV-6D0*QF*VF*SF1I
41461           RVA=RVA+3D0*(VF**2+1D0)*SF1W
41462           RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
41463      &    2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
41464         ENDIF
41465   110 CONTINUE
41466       RSUM=RQQ
41467       IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
41468
41469 C...Calculate cross-section, including QCD corrections.
41470       PARJ(141)=RQQ
41471       PARJ(142)=RTOT
41472       PARJ(143)=RTOT*RQCD
41473       PARJ(144)=PARJ(143)
41474       PARJ(145)=PARJ(141)*86.8D0/ECM**2
41475       PARJ(146)=PARJ(142)*86.8D0/ECM**2
41476       PARJ(147)=PARJ(143)*86.8D0/ECM**2
41477       PARJ(148)=PARJ(147)
41478       PARJ(157)=RSUM*RQCD
41479       PARJ(158)=0D0
41480       PARJ(159)=0D0
41481       XTOT=PARJ(147)
41482       IF(MSTJ(107).LE.0) RETURN
41483
41484 C...Virtual cross-section.
41485       XKL=PARJ(135)
41486       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41487       ALE=2D0*LOG(ECM/PYMASS(11))-1D0
41488       SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
41489      &1.526D0*LOG(ECM**2/0.932D0)
41490
41491 C...Soft and hard radiative cross-section in QED case.
41492       IF(MSTJ(102).LE.1) THEN
41493         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
41494         SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
41495         SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
41496
41497 C...Soft and hard radiative cross-section in QFD case.
41498       ELSE
41499         SZM=1D0-(PARJ(123)/ECM)**2
41500         SZW=PARJ(123)*PARJ(124)/ECM**2
41501         PARJ(161)=-RQQ/RSUM
41502         PARJ(162)=-(RQQ+RQV+RVA)/RSUM
41503         PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
41504         PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
41505      &  4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
41506         SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
41507      &  RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
41508         SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
41509      &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
41510      &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
41511         SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
41512      &  (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
41513      &  LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
41514      &  PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
41515       ENDIF
41516
41517 C...Total cross-section and fraction of hard photon events.
41518       PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
41519       PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
41520       PARJ(144)=PARJ(157)
41521       PARJ(148)=PARJ(144)*86.8D0/ECM**2
41522       XTOT=PARJ(148)
41523
41524       RETURN
41525       END
41526
41527 C*********************************************************************
41528
41529 *$ CREATE PYRADK.FOR
41530 *COPY PYRADK
41531 C...PYRADK
41532 C...Generates initial state photon radiation.
41533
41534       SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
41535
41536 C...Double precision and integer declarations.
41537       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41538       INTEGER PYK,PYCHGE,PYCOMP
41539 C...Commonblocks.
41540       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41541       SAVE /PYDAT1/
41542
41543 C...Function: cumulative hard photon spectrum in QFD case.
41544       FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
41545      &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
41546
41547 C...Determine whether radiative photon or not.
41548       MK=0
41549       PAK=0D0
41550       IF(PARJ(160).LT.PYR(0)) RETURN
41551       MK=1
41552
41553 C...Photon energy range. Find photon momentum in QED case.
41554       XKL=PARJ(135)
41555       XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
41556       IF(MSTJ(102).LE.1) THEN
41557   100   XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
41558         IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
41559
41560 C...Ditto in QFD case, by numerical inversion of integrated spectrum.
41561       ELSE
41562         SZM=1D0-(PARJ(123)/ECM)**2
41563         SZW=PARJ(123)*PARJ(124)/ECM**2
41564         FXKL=FXK(XKL)
41565         FXKU=FXK(XKU)
41566         FXKD=1D-4*(FXKU-FXKL)
41567         FXKR=FXKL+PYR(0)*(FXKU-FXKL)
41568         NXK=0
41569   110   NXK=NXK+1
41570         XK=0.5D0*(XKL+XKU)
41571         FXKV=FXK(XK)
41572         IF(FXKV.GT.FXKR) THEN
41573           XKU=XK
41574           FXKU=FXKV
41575         ELSE
41576           XKL=XK
41577           FXKL=FXKV
41578         ENDIF
41579         IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
41580         XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
41581       ENDIF
41582       PAK=0.5D0*ECM*XK
41583
41584 C...Photon polar and azimuthal angle.
41585       PME=2D0*(PYMASS(11)/ECM)**2
41586   120 CTHM=PME*(2D0/PME)**PYR(0)
41587       IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
41588      &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
41589       CTHE=1D0-CTHM
41590       IF(PYR(0).GT.0.5D0) CTHE=-CTHE
41591       STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
41592       THEK=PYANGL(CTHE,STHE)
41593       PHIK=PARU(2)*PYR(0)
41594
41595 C...Rotation angle for hadronic system.
41596       SGN=1D0
41597       IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
41598      &PYR(0)) SGN=-1D0
41599       ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
41600      &(2D0-XK*(1D0-SGN*CTHE)))
41601
41602       RETURN
41603       END
41604
41605 C*********************************************************************
41606
41607 *$ CREATE PYXKFL.FOR
41608 *COPY PYXKFL
41609 C...PYXKFL
41610 C...Selects flavour for produced qqbar pair.
41611
41612       SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
41613
41614 C...Double precision and integer declarations.
41615       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41616       INTEGER PYK,PYCHGE,PYCOMP
41617 C...Commonblocks.
41618       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41619       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41620       SAVE /PYDAT1/,/PYDAT2/
41621
41622 C...Calculate maximum weight in QED or QFD case.
41623       IF(MSTJ(102).LE.1) THEN
41624         RFMAX=4D0/9D0
41625       ELSE
41626         POLL=1D0-PARJ(131)*PARJ(132)
41627         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
41628         SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
41629         SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
41630         VE=4D0*PARU(102)-1D0
41631         HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
41632         HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
41633         RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
41634      &  ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
41635      &  (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
41636      &  1D0)*HF1W)
41637       ENDIF
41638
41639 C...Choose flavour. Gives charge and velocity.
41640       NTRY=0
41641   100 NTRY=NTRY+1
41642       IF(NTRY.GT.100) THEN
41643         CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
41644         KFLC=0
41645         RETURN
41646       ENDIF
41647       KFLC=KFL
41648       IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
41649       MSTJ(93)=1
41650       PMQ=PYMASS(KFLC)
41651       IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
41652       QF=KCHG(KFLC,1)/3D0
41653       VQ=1D0
41654       IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
41655
41656 C...Calculate weight in QED or QFD case.
41657       IF(MSTJ(102).LE.1) THEN
41658         RF=QF**2
41659         RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
41660       ELSE
41661         VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
41662         RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
41663         RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
41664      &  VQ**3*HF1W
41665         IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
41666       ENDIF
41667
41668 C...Weighting or new event (radiative photon). Cross-section update.
41669       IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
41670       PARJ(158)=PARJ(158)+1D0
41671       IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
41672       IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
41673       IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
41674       PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
41675       PARJ(148)=PARJ(144)*86.8D0/ECM**2
41676
41677       RETURN
41678       END
41679
41680 C*********************************************************************
41681
41682 *$ CREATE PYXJET.FOR
41683 *COPY PYXJET
41684 C...PYXJET
41685 C...Selects number of jets in matrix element approach.
41686
41687       SUBROUTINE PYXJET(ECM,NJET,CUT)
41688
41689 C...Double precision and integer declarations.
41690       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41691       INTEGER PYK,PYCHGE,PYCOMP
41692 C...Commonblocks.
41693       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41694       SAVE /PYDAT1/
41695 C...Local array and data.
41696       DIMENSION ZHUT(5)
41697       DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
41698
41699 C...Trivial result for two-jets only, including parton shower.
41700       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41701         CUT=0D0
41702
41703 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
41704       ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
41705         CF=4D0/3D0
41706         IF(MSTJ(109).EQ.2) CF=1D0
41707         IF(MSTJ(111).EQ.0) THEN
41708           Q2=ECM**2
41709           Q2R=ECM**2
41710         ELSEIF(MSTU(111).EQ.0) THEN
41711           PARJ(169)=MIN(1D0,PARJ(129))
41712           Q2=PARJ(169)*ECM**2
41713           PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
41714      &    ((33D0-2D0*MSTU(112))*PARU(111)))))
41715           Q2R=PARJ(168)*ECM**2
41716         ELSE
41717           PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
41718           Q2=PARJ(169)*ECM**2
41719           PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
41720      &    (2D0*PARU(112)/ECM)**2))
41721           Q2R=PARJ(168)*ECM**2
41722         ENDIF
41723
41724 C...alpha_strong for R and R itself.
41725         ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
41726         IF(IABS(MSTJ(101)).EQ.1) THEN
41727           RQCD=1D0+ALSPI
41728         ELSEIF(MSTJ(109).EQ.0) THEN
41729           RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
41730           IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
41731      &    (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
41732         ELSE
41733           RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
41734         ENDIF
41735
41736 C...alpha_strong for jet rate. Initial value for y cut.
41737         ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41738         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
41739         IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
41740      &  CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
41741         IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41742
41743 C...Parametrization of first order three-jet cross-section.
41744   100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
41745           PARJ(152)=0D0
41746         ELSE
41747           PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
41748      &    LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
41749      &    (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
41750      &    (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
41751           IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
41752      &    PARJ(152)=0D0
41753         ENDIF
41754
41755 C...Parametrization of second order three-jet cross-section.
41756         IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
41757      &  CUT.GE.0.25D0) THEN
41758           PARJ(153)=0D0
41759         ELSEIF(MSTJ(110).LE.1) THEN
41760           CT=LOG(1D0/CUT-2D0)
41761           PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
41762      &    0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
41763
41764 C...Interpolation in second/first order ratio for Zhu parametrization.
41765         ELSEIF(MSTJ(110).EQ.2) THEN
41766           IZA=0
41767           DO 110 IY=1,5
41768             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41769   110     CONTINUE
41770           IF(IZA.NE.0) THEN
41771             ZHURAT=ZHUT(IZA)
41772           ELSE
41773             IZ=100D0*CUT
41774             ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
41775           ENDIF
41776           PARJ(153)=ALSPI*PARJ(152)*ZHURAT
41777         ENDIF
41778
41779 C...Shift in second order three-jet cross-section with optimized Q^2.
41780         IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
41781      &  .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
41782      &  (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
41783
41784 C...Parametrization of second order four-jet cross-section.
41785         IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
41786           PARJ(154)=0D0
41787         ELSE
41788           CT=LOG(1D0/CUT-5D0)
41789           IF(CUT.LE.0.018D0) THEN
41790             XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
41791             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
41792      &      0.4059D0*CT**2)
41793             XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
41794             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41795           ELSE
41796             XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
41797             IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
41798      &      0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
41799             XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
41800      &      0.002093D0*CT**3)
41801             IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
41802           ENDIF
41803           PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
41804           PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
41805         ENDIF
41806
41807 C...If negative three-jet rate, change y' optimization parameter.
41808         IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
41809      &  PARJ(169).LT.0.99D0) THEN
41810           PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41811           Q2=PARJ(169)*ECM**2
41812           ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41813           GOTO 100
41814         ENDIF
41815
41816 C...If too high cross-section, use harder cuts, or fail.
41817         IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
41818           IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
41819      &    PARJ(169).LT.0.99D0) THEN
41820             PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
41821             Q2=PARJ(169)*ECM**2
41822             ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
41823             GOTO 100
41824           ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
41825             CALL PYERRM(26,
41826      &      '(PYXJET:) no allowed y cut value for Zhu parametrization')
41827           ENDIF
41828           CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
41829      &    PARJ(154))**(-1D0/3D0)
41830           IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
41831           GOTO 100
41832         ENDIF
41833
41834 C...Scalar gluon (first order only).
41835       ELSE
41836         ALSPI=PYALPS(ECM**2)/PARU(1)
41837         CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
41838         PARJ(152)=0D0
41839         IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
41840      &  LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
41841         PARJ(153)=0D0
41842         PARJ(154)=0D0
41843       ENDIF
41844
41845 C...Select number of jets.
41846       PARJ(150)=CUT
41847       IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
41848         NJET=2
41849       ELSEIF(MSTJ(101).LE.0) THEN
41850         NJET=MIN(4,2-MSTJ(101))
41851       ELSE
41852         RNJ=PYR(0)
41853         NJET=2
41854         IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
41855         IF(PARJ(154).GT.RNJ) NJET=4
41856       ENDIF
41857
41858       RETURN
41859       END
41860
41861 C*********************************************************************
41862
41863 *$ CREATE PYX3JT.FOR
41864 *COPY PYX3JT
41865 C...PYX3JT
41866 C...Selects the kinematical variables of three-jet events.
41867
41868       SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
41869
41870 C...Double precision and integer declarations.
41871       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41872       INTEGER PYK,PYCHGE,PYCOMP
41873 C...Commonblocks.
41874       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41875       SAVE /PYDAT1/
41876 C...Local array.
41877       DIMENSION ZHUP(5,12)
41878
41879 C...Coefficients of Zhu second order parametrization.
41880       DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
41881      &18.29D0,  89.56D0,  4.541D0,  -52.09D0, -109.8D0,  24.90D0,
41882      &11.63D0,  3.683D0,  17.50D0,0.002440D0, -1.362D0,-0.3537D0,
41883      &11.42D0,  6.299D0, -22.55D0,  -8.915D0,  59.25D0, -5.855D0,
41884      &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
41885      &7.847D0, -3.964D0, -35.83D0,   1.178D0,  29.39D0, 0.2806D0,
41886      &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
41887      &5.441D0, -56.89D0, -50.27D0,   15.13D0,  114.3D0, -18.19D0,
41888      &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
41889      &-17.65D0,  51.44D0, -58.32D0,   70.95D0, -255.7D0, -78.99D0,
41890      &476.9D0,  29.65D0, -239.3D0,  0.4745D0, -1.174D0,  6.081D0/
41891
41892 C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
41893       DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
41894      &X**7/49D0
41895
41896 C...Event type. Mass effect factors and other common constants.
41897       MSTJ(120)=2
41898       MSTJ(121)=0
41899       PMQ=PYMASS(KFL)
41900       QME=(2D0*PMQ/ECM)**2
41901       IF(MSTJ(109).NE.1) THEN
41902         CUTL=LOG(CUT)
41903         CUTD=LOG(1D0/CUT-2D0)
41904         IF(MSTJ(109).EQ.0) THEN
41905           CF=4D0/3D0
41906           CN=3D0
41907           TR=2D0
41908           WTMX=MIN(20D0,37D0-6D0*CUTD)
41909           IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
41910         ELSE
41911           CF=1D0
41912           CN=0D0
41913           TR=12D0
41914           WTMX=0D0
41915         ENDIF
41916
41917 C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
41918         ALS2PI=PARU(118)/PARU(2)
41919         WTOPT=0D0
41920         IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
41921      &  LOG(PARJ(169))*ALS2PI
41922         WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
41923
41924 C...Choose three-jet events in allowed region.
41925   100   NJET=3
41926   110   Y13L=CUTL+CUTD*PYR(0)
41927         Y23L=CUTL+CUTD*PYR(0)
41928         Y13=EXP(Y13L)
41929         Y23=EXP(Y23L)
41930         Y12=1D0-Y13-Y23
41931         IF(Y12.LE.CUT) GOTO 110
41932         IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
41933
41934 C...Second order corrections.
41935         IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
41936           Y12L=LOG(Y12)
41937           Y13M=LOG(1D0-Y13)
41938           Y23M=LOG(1D0-Y23)
41939           Y12M=LOG(1D0-Y12)
41940           IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
41941           IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
41942           IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
41943           IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
41944           IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
41945           IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
41946           WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
41947           WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
41948      &    2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
41949      &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
41950      &    11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
41951      &    (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
41952      &    TR*(2D0*CUTL/3D0-10D0/9D0)+
41953      &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
41954      &    Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
41955      &    (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
41956      &    Y13*Y23)/(Y12+Y13)**2)/WT1+
41957      &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
41958      &    ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
41959      &    Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
41960      &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
41961      &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
41962      &    2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
41963      &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
41964           IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41965           IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41966           PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
41967
41968         ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
41969 C...Second order corrections; Zhu parametrization of ERT.
41970           ZX=(Y23-Y13)**2
41971           ZY=1D0-Y12
41972           IZA=0
41973           DO 120 IY=1,5
41974             IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
41975   120     CONTINUE
41976           IF(IZA.NE.0) THEN
41977             IZ=IZA
41978             WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41979      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41980      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41981      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41982           ELSE
41983             IZ=100D0*CUT
41984             WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41985      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41986      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41987      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41988             IZ=IZ+1
41989             WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
41990      &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
41991      &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
41992      &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
41993             WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
41994           ENDIF
41995           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
41996           IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
41997           PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
41998         ENDIF
41999
42000 C...Impose mass cuts (gives two jets). For fixed jet number new try.
42001         X1=1D0-Y23
42002         X2=1D0-Y13
42003         X3=1D0-Y12
42004         IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
42005         IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
42006      &  0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
42007      &  (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
42008         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
42009
42010 C...Scalar gluon model (first order only, no mass effects).
42011       ELSE
42012   130   NJET=3
42013   140   X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
42014         IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
42015         YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
42016         X1=1D0-0.5D0*(X3+YD)
42017         X2=1D0-0.5D0*(X3-YD)
42018         IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
42019         IF(MSTJ(102).GE.2) THEN
42020           IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
42021      &    X3**2*PYR(0)) NJET=2
42022         ENDIF
42023         IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
42024       ENDIF
42025
42026       RETURN
42027       END
42028
42029 C*********************************************************************
42030
42031 *$ CREATE PYX4JT.FOR
42032 *COPY PYX4JT
42033 C...PYX4JT
42034 C...Selects the kinematical variables of four-jet events.
42035
42036       SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
42037
42038 C...Double precision and integer declarations.
42039       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42040       INTEGER PYK,PYCHGE,PYCOMP
42041 C...Commonblocks.
42042       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42043       SAVE /PYDAT1/
42044 C...Local arrays.
42045       DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
42046
42047 C...Common constants. Colour factors for QCD and Abelian gluon theory.
42048       PMQ=PYMASS(KFL)
42049       QME=(2D0*PMQ/ECM)**2
42050       CT=LOG(1D0/CUT-5D0)
42051       IF(MSTJ(109).EQ.0) THEN
42052         CF=4D0/3D0
42053         CN=3D0
42054         TR=2.5D0
42055       ELSE
42056         CF=1D0
42057         CN=0D0
42058         TR=15D0
42059       ENDIF
42060
42061 C...Choice of process (qqbargg or qqbarqqbar).
42062   100 NJET=4
42063       IT=1
42064       IF(PARJ(155).GT.PYR(0)) IT=2
42065       IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
42066       IF(IT.EQ.1) WTMX=0.7D0/CUT**2
42067       IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
42068       IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
42069       ID=1
42070
42071 C...Sample the five kinematical variables (for qqgg preweighted in y34).
42072   110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42073       Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
42074       IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
42075       IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
42076       IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
42077       VT=PYR(0)
42078       CP=COS(PARU(1)*PYR(0))
42079       Y14=(Y134-Y34)*VT
42080       Y13=Y134-Y14-Y34
42081       VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
42082       Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
42083      &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
42084       Y23=Y234-Y34-Y24
42085       Y12=1D0-Y134-Y23-Y24
42086       IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
42087       Y123=Y12+Y13+Y23
42088       Y124=Y12+Y14+Y24
42089
42090 C...Calculate matrix elements for qqgg or qqqq process.
42091       IC=0
42092       WTTOT=0D0
42093   120 IC=IC+1
42094       IF(IT.EQ.1) THEN
42095         WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
42096      &  3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
42097      &  Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
42098      &  Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
42099      &  2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
42100      &  (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
42101      &  Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
42102      &  (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
42103         WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
42104      &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
42105      &  Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
42106      &  Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
42107         WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
42108      &  2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
42109      &  Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
42110      &  3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
42111      &  3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
42112      &  (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
42113      &  3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
42114      &  2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
42115      &  2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
42116      &  3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
42117      &  2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
42118      &  2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
42119         WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
42120      &  4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
42121      &  Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
42122      &  4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
42123      &  2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
42124      &  4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
42125      &  (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
42126      &  2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
42127      &  2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
42128      &  4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
42129      &  Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
42130      &  4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
42131      &  4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
42132      &  2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
42133      &  2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
42134      &  Y12*Y13**2)/(4D0*Y34**2*Y134**2)
42135         WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
42136      &  CN*WTC(IC))/8D0
42137       ELSE
42138         WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
42139      &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
42140      &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
42141      &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
42142      &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
42143      &  Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
42144      &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
42145      &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
42146      &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
42147         WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
42148      &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
42149      &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
42150      &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
42151      &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
42152      &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
42153      &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
42154      &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
42155         WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
42156       ENDIF
42157
42158 C...Permutations of momenta in matrix element. Weighting.
42159   130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
42160         YSAV=Y13
42161         Y13=Y14
42162         Y14=YSAV
42163         YSAV=Y23
42164         Y23=Y24
42165         Y24=YSAV
42166         YSAV=Y123
42167         Y123=Y124
42168         Y124=YSAV
42169       ENDIF
42170       IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
42171         YSAV=Y13
42172         Y13=Y23
42173         Y23=YSAV
42174         YSAV=Y14
42175         Y14=Y24
42176         Y24=YSAV
42177         YSAV=Y134
42178         Y134=Y234
42179         Y234=YSAV
42180       ENDIF
42181       IF(IC.LE.3) GOTO 120
42182       IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
42183       IC=5
42184
42185 C...qqgg events: string configuration and event type.
42186       IF(IT.EQ.1) THEN
42187         IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
42188           PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
42189      &    WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
42190           IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
42191      &    WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
42192           IF(ID.EQ.2) GOTO 130
42193         ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
42194           PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
42195           IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
42196           IF(ID.EQ.2) GOTO 130
42197         ENDIF
42198         MSTJ(120)=3
42199         IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
42200      &  WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
42201         KFLN=21
42202
42203 C...Mass cuts. Kinematical variables out.
42204         IF(Y12.LE.CUT+QME) NJET=2
42205         IF(NJET.EQ.2) GOTO 150
42206         Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
42207         X1=1D0-(1D0-Q12)*Y234-Q12*Y134
42208         X4=1D0-(1D0-Q12)*Y134-Q12*Y234
42209         X2=1D0-Y124
42210         X12=(1D0-Q12)*Y13+Q12*Y23
42211         X14=Y12-0.5D0*QME
42212         IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42213
42214 C...qqbarqqbar events: string configuration, choose new flavour.
42215       ELSE
42216         IF(ID.EQ.1) THEN
42217           WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
42218           IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
42219           IF(WTR.LT.WTD(3)+WTD(4)) ID=3
42220           IF(WTR.LT.WTD(4)) ID=4
42221           IF(ID.GE.2) GOTO 130
42222         ENDIF
42223         MSTJ(120)=5
42224         PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
42225   140   KFLN=1+INT(5D0*PYR(0))
42226         IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
42227         IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
42228         IF(KFLN.GT.MSTJ(104)) NJET=2
42229         PMQN=PYMASS(KFLN)
42230         QMEN=(2D0*PMQN/ECM)**2
42231
42232 C...Mass cuts. Kinematical variables out.
42233         IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
42234         IF(NJET.EQ.2) GOTO 150
42235         Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
42236         Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
42237         X1=1D0-(1D0-Q24)*Y123-Q24*Y134
42238         X4=1D0-(1D0-Q24)*Y134-Q24*Y123
42239         X2=1D0-(1D0-Q13)*Y234-Q13*Y124
42240         X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
42241      &  Q13*Y23)
42242         X14=Y24-0.5D0*QME
42243         X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
42244      &  Q13*Y14)
42245         IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
42246      &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
42247         IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
42248       ENDIF
42249   150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
42250
42251       RETURN
42252       END
42253
42254 C*********************************************************************
42255
42256 *$ CREATE PYXDIF.FOR
42257 *COPY PYXDIF
42258 C...PYXDIF
42259 C...Gives the angular orientation of events.
42260
42261       SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
42262
42263 C...Double precision and integer declarations.
42264       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42265       INTEGER PYK,PYCHGE,PYCOMP
42266 C...Commonblocks.
42267       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42268       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42269       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42270       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42271
42272 C...Charge. Factors depending on polarization for QED case.
42273       QF=KCHG(KFL,1)/3D0
42274       POLL=1D0-PARJ(131)*PARJ(132)
42275       POLD=PARJ(132)-PARJ(131)
42276       IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
42277         HF1=POLL
42278         HF2=0D0
42279         HF3=PARJ(133)**2
42280         HF4=0D0
42281
42282 C...Factors depending on flavour, energy and polarization for QFD case.
42283       ELSE
42284         SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
42285         SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
42286         SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
42287         AE=-1D0
42288         VE=4D0*PARU(102)-1D0
42289         AF=SIGN(1D0,QF)
42290         VF=AF-4D0*QF*PARU(102)
42291         HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
42292      &  (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
42293         HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
42294      &  (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
42295         HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
42296      &  SFW*SFF**2*(VE**2-AE**2))
42297         HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
42298      &  SFF*AE
42299       ENDIF
42300
42301 C...Mass factor. Differential cross-sections for two-jet events.
42302       SQ2=SQRT(2D0)
42303       QME=0D0
42304       IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
42305      &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
42306       IF(NJET.EQ.2) THEN
42307         SIGU=4D0*SQRT(1D0-QME)
42308         SIGL=2D0*QME*SQRT(1D0-QME)
42309         SIGT=0D0
42310         SIGI=0D0
42311         SIGA=0D0
42312         SIGP=4D0
42313
42314 C...Kinematical variables. Reduce four-jet event to three-jet one.
42315       ELSE
42316         IF(NJET.EQ.3) THEN
42317           X1=2D0*P(NC+1,4)/ECM
42318           X2=2D0*P(NC+3,4)/ECM
42319         ELSE
42320           ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
42321      &    (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
42322           X1=2D0*P(NC+1,4)/ECMR
42323           X2=2D0*P(NC+4,4)/ECMR
42324         ENDIF
42325
42326 C...Differential cross-sections for three-jet (or reduced four-jet).
42327         XQ=(1D0-X1)/(1D0-X2)
42328         CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
42329         ST12=SQRT(1D0-CT12**2)
42330         IF(MSTJ(109).NE.1) THEN
42331           SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
42332      &    QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
42333           SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
42334      &    0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
42335      &    X2)*XQ
42336           SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
42337           SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
42338      &    QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
42339           SIGA=X2**2*ST12/SQ2
42340           SIGP=2D0*(X1**2-X2**2*CT12)
42341
42342 C...Differential cross-sect for scalar gluons (no mass effects).
42343         ELSE
42344           X3=2D0-X1-X2
42345           XT=X2*ST12
42346           CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
42347           SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
42348      &    PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
42349           SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
42350      &    PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
42351           SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
42352      &    PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
42353           SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
42354      &    PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
42355           SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
42356           SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
42357         ENDIF
42358       ENDIF
42359
42360 C...Upper bounds for differential cross-section.
42361       HF1A=ABS(HF1)
42362       HF2A=ABS(HF2)
42363       HF3A=ABS(HF3)
42364       HF4A=ABS(HF4)
42365       SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
42366      &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
42367      &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
42368      &2D0*HF2A*ABS(SIGP)
42369
42370 C...Generate angular orientation according to differential cross-sect.
42371   100 CHI=PARU(2)*PYR(0)
42372       CTHE=2D0*PYR(0)-1D0
42373       PHI=PARU(2)*PYR(0)
42374       CCHI=COS(CHI)
42375       SCHI=SIN(CHI)
42376       C2CHI=COS(2D0*CHI)
42377       S2CHI=SIN(2D0*CHI)
42378       THE=ACOS(CTHE)
42379       STHE=SIN(THE)
42380       C2PHI=COS(2D0*(PHI-PARJ(134)))
42381       S2PHI=SIN(2D0*(PHI-PARJ(134)))
42382       SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
42383      &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
42384      &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
42385      &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
42386      &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
42387      &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
42388      &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
42389       IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
42390
42391       RETURN
42392       END
42393
42394 C*********************************************************************
42395
42396 *$ CREATE PYONIA.FOR
42397 *COPY PYONIA
42398 C...PYONIA
42399 C...Generates Upsilon and toponium decays into three gluons
42400 C...or two gluons and a photon.
42401
42402       SUBROUTINE PYONIA(KFL,ECM)
42403
42404 C...Double precision and integer declarations.
42405       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42406       INTEGER PYK,PYCHGE,PYCOMP
42407 C...Commonblocks.
42408       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
42409       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42410       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42411       SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
42412
42413 C...Printout. Check input parameters.
42414       IF(MSTU(12).GE.1) CALL PYLIST(0)
42415       IF(KFL.LT.0.OR.KFL.GT.8) THEN
42416         CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
42417         IF(MSTU(21).GE.1) RETURN
42418       ENDIF
42419       IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
42420         CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
42421         IF(MSTU(21).GE.1) RETURN
42422       ENDIF
42423
42424 C...Initial e+e- and onium state (optional).
42425       NC=0
42426       IF(MSTJ(115).GE.2) THEN
42427         NC=NC+2
42428         CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
42429         K(NC-1,1)=21
42430         CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
42431         K(NC,1)=21
42432       ENDIF
42433       KFLC=IABS(KFL)
42434       IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
42435         NC=NC+1
42436         KF=110*KFLC+3
42437         MSTU10=MSTU(10)
42438         MSTU(10)=1
42439         P(NC,5)=ECM
42440         CALL PY1ENT(NC,KF,ECM,0D0,0D0)
42441         K(NC,1)=21
42442         K(NC,3)=1
42443         MSTU(10)=MSTU10
42444       ENDIF
42445
42446 C...Choose x1 and x2 according to matrix element.
42447       NTRY=0
42448   100 X1=PYR(0)
42449       X2=PYR(0)
42450       X3=2D0-X1-X2
42451       IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
42452      &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
42453       NTRY=NTRY+1
42454       NJET=3
42455       IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
42456       IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
42457
42458 C...Photon-gluon-gluon events. Small system modifications. Jet origin.
42459       MSTU(111)=MSTJ(108)
42460       IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
42461      &MSTU(111)=1
42462       PARU(112)=PARJ(121)
42463       IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
42464       QF=0D0
42465       IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
42466       RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
42467       MK=0
42468       ECMC=ECM
42469       IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
42470         IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
42471      &  NJET=2
42472         IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
42473         IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
42474       ELSE
42475         MK=1
42476         ECMC=SQRT(1D0-X1)*ECM
42477         IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
42478         K(NC+1,1)=1
42479         K(NC+1,2)=22
42480         K(NC+1,4)=0
42481         K(NC+1,5)=0
42482         IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
42483         IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
42484         IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
42485         IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
42486         NJET=2
42487         IF(ECMC.LT.4D0*PARJ(127)) THEN
42488           MSTU10=MSTU(10)
42489           MSTU(10)=1
42490           P(NC+2,5)=ECMC
42491           CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
42492           MSTU(10)=MSTU10
42493           NJET=0
42494         ENDIF
42495       ENDIF
42496       DO 110 IP=NC+1,N
42497         K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
42498   110 CONTINUE
42499
42500 C...Differential cross-sections. Upper limit for cross-section.
42501       IF(MSTJ(106).EQ.1) THEN
42502         SQ2=SQRT(2D0)
42503         HF1=1D0-PARJ(131)*PARJ(132)
42504         HF3=PARJ(133)**2
42505         CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
42506         ST13=SQRT(1D0-CT13**2)
42507         SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
42508         SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
42509         SIGT=0.5D0*SIGL
42510         SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
42511         SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
42512      &  2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
42513
42514 C...Angular orientation of event.
42515   120   CHI=PARU(2)*PYR(0)
42516         CTHE=2D0*PYR(0)-1D0
42517         PHI=PARU(2)*PYR(0)
42518         CCHI=COS(CHI)
42519         SCHI=SIN(CHI)
42520         C2CHI=COS(2D0*CHI)
42521         S2CHI=SIN(2D0*CHI)
42522         THE=ACOS(CTHE)
42523         STHE=SIN(THE)
42524         C2PHI=COS(2D0*(PHI-PARJ(134)))
42525         S2PHI=SIN(2D0*(PHI-PARJ(134)))
42526         SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
42527      &  STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
42528      &  C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
42529      &  2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
42530      &  (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
42531         IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
42532         CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
42533         CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
42534       ENDIF
42535
42536 C...Generate parton shower. Rearrange along strings and check.
42537       IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
42538         CALL PYSHOW(NC+MK+1,-NJET,ECMC)
42539         MSTJ14=MSTJ(14)
42540         IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
42541         IF(MSTJ(105).GE.0) MSTU(28)=0
42542         CALL PYPREP(0)
42543         MSTJ(14)=MSTJ14
42544         IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
42545       ENDIF
42546
42547 C...Generate fragmentation. Information for PYTABU:
42548       IF(MSTJ(105).EQ.1) CALL PYEXEC
42549       MSTU(161)=110*KFLC+3
42550       MSTU(162)=0
42551
42552       RETURN
42553       END
42554
42555 C*********************************************************************
42556
42557 *$ CREATE PYBOOK.FOR
42558 *COPY PYBOOK
42559 C...PYBOOK
42560 C...Books a histogram.
42561
42562       SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
42563
42564 C...Double precision declaration.
42565       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42566 C...Commonblock.
42567       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42568       SAVE /PYBINS/
42569 C...Local character variables.
42570       CHARACTER TITLE*(*), TITFX*60
42571
42572 C...Check that input is sensible. Find initial address in memory.
42573       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42574      &'(PYBOOK:) not allowed histogram number')
42575       IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
42576      &'(PYBOOK:) not allowed number of bins')
42577       IF(XL.GE.XU) CALL PYERRM(28,
42578      &'(PYBOOK:) x limits in wrong order')
42579       INDX(ID)=IHIST(4)
42580       IHIST(4)=IHIST(4)+28+NX
42581       IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
42582      &'(PYBOOK:) out of histogram space')
42583       IS=INDX(ID)
42584
42585 C...Store histogram size and reset contents.
42586       BIN(IS+1)=NX
42587       BIN(IS+2)=XL
42588       BIN(IS+3)=XU
42589       BIN(IS+4)=(XU-XL)/NX
42590       CALL PYNULL(ID)
42591
42592 C...Store title by conversion to integer to double precision.
42593       TITFX=TITLE//' '
42594       DO 100 IT=1,20
42595         BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
42596      &  256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
42597   100 CONTINUE
42598
42599       RETURN
42600       END
42601
42602 C*********************************************************************
42603
42604 *$ CREATE PYFILL.FOR
42605 *COPY PYFILL
42606 C...PYFILL
42607 C...Fills entry in histogram.
42608
42609       SUBROUTINE PYFILL(ID,X,W)
42610
42611 C...Double precision declaration.
42612       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42613 C...Commonblock.
42614       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42615       SAVE /PYBINS/
42616
42617 C...Find initial address in memory. Increase number of entries.
42618       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42619      &'(PYFILL:) not allowed histogram number')
42620       IS=INDX(ID)
42621       IF(IS.EQ.0) CALL PYERRM(28,
42622      &'(PYFILL:) filling unbooked histogram')
42623       BIN(IS+5)=BIN(IS+5)+1D0
42624
42625 C...Find bin in x, including under/overflow, and fill.
42626       IF(X.LT.BIN(IS+2)) THEN
42627         BIN(IS+6)=BIN(IS+6)+W
42628       ELSEIF(X.GE.BIN(IS+3)) THEN
42629         BIN(IS+8)=BIN(IS+8)+W
42630       ELSE
42631         BIN(IS+7)=BIN(IS+7)+W
42632         IX=(X-BIN(IS+2))/BIN(IS+4)
42633         IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
42634         BIN(IS+9+IX)=BIN(IS+9+IX)+W
42635       ENDIF
42636
42637       RETURN
42638       END
42639
42640 C*********************************************************************
42641
42642 *$ CREATE PYFACT.FOR
42643 *COPY PYFACT
42644 C...PYFACT
42645 C...Multiplies histogram contents by factor.
42646
42647       SUBROUTINE PYFACT(ID,F)
42648
42649 C...Double precision declaration.
42650       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42651 C...Commonblock.
42652       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42653       SAVE /PYBINS/
42654
42655 C...Find initial address in memory. Multiply all contents bins.
42656       IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
42657      &'(PYFACT:) not allowed histogram number')
42658       IS=INDX(ID)
42659       IF(IS.EQ.0) CALL PYERRM(28,
42660      &'(PYFACT:) scaling unbooked histogram')
42661       DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
42662         BIN(IX)=F*BIN(IX)
42663   100 CONTINUE
42664
42665       RETURN
42666       END
42667
42668 C*********************************************************************
42669
42670 *$ CREATE PYOPER.FOR
42671 *COPY PYOPER
42672 C...PYOPER
42673 C...Performs operations between histograms.
42674
42675       SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
42676
42677 C...Double precision declaration.
42678       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42679 C...Commonblock.
42680       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42681       SAVE /PYBINS/
42682 C...Character variable.
42683       CHARACTER OPER*(*)
42684
42685 C...Find initial addresses in memory, and histogram size.
42686       IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
42687      &'(PYFACT:) not allowed histogram number')
42688       IS1=INDX(ID1)
42689       IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
42690       IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
42691       NX=NINT(BIN(IS3+1))
42692       IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
42693
42694 C...Update info on number of histogram entries.
42695       IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
42696         BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
42697       ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
42698         BIN(IS3+5)=BIN(IS1+5)
42699       ENDIF
42700
42701 C...Operations on pair of histograms: addition, subtraction,
42702 C...multiplication, division.
42703       IF(OPER.EQ.'+') THEN
42704         DO 100 IX=6,8+NX
42705           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
42706   100   CONTINUE
42707       ELSEIF(OPER.EQ.'-') THEN
42708         DO 110 IX=6,8+NX
42709           BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
42710   110   CONTINUE
42711       ELSEIF(OPER.EQ.'*') THEN
42712         DO 120 IX=6,8+NX
42713           BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
42714   120   CONTINUE
42715       ELSEIF(OPER.EQ.'/') THEN
42716         DO 130 IX=6,8+NX
42717           FA2=F2*BIN(IS2+IX)
42718           IF(ABS(FA2).LE.1D-20) THEN
42719             BIN(IS3+IX)=0D0
42720           ELSE
42721             BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
42722           ENDIF
42723   130   CONTINUE
42724
42725 C...Operations on single histogram: multiplication+addition,
42726 C...square root+addition, logarithm+addition.
42727       ELSEIF(OPER.EQ.'A') THEN
42728         DO 140 IX=6,8+NX
42729           BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
42730   140   CONTINUE
42731       ELSEIF(OPER.EQ.'S') THEN
42732         DO 150 IX=6,8+NX
42733           BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
42734   150   CONTINUE
42735       ELSEIF(OPER.EQ.'L') THEN
42736         ZMIN=1D20
42737         DO 160 IX=9,8+NX
42738           IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
42739      &    ZMIN=0.8D0*BIN(IS1+IX)
42740   160   CONTINUE
42741         DO 170 IX=6,8+NX
42742           BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
42743   170   CONTINUE
42744
42745 C...Operation on two or three histograms: average and
42746 C...standard deviation.
42747       ELSEIF(OPER.EQ.'M') THEN
42748         DO 180 IX=6,8+NX
42749           IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42750             BIN(IS2+IX)=0D0
42751           ELSE
42752             BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
42753           ENDIF
42754           IF(ID3.NE.0) THEN
42755             IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
42756               BIN(IS3+IX)=0D0
42757             ELSE
42758               BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
42759      &        BIN(IS2+IX)**2))
42760             ENDIF
42761           ENDIF
42762           BIN(IS1+IX)=F1*BIN(IS1+IX)
42763   180   CONTINUE
42764       ENDIF
42765
42766       RETURN
42767       END
42768
42769 C*********************************************************************
42770
42771 *$ CREATE PYHIST.FOR
42772 *COPY PYHIST
42773 C...PYHIST
42774 C...Prints and resets all histograms.
42775
42776       SUBROUTINE PYHIST
42777
42778 C...Double precision declaration.
42779       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42780 C...Commonblock.
42781       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42782       SAVE /PYBINS/
42783
42784 C...Loop over histograms, print and reset used ones.
42785       DO 100 ID=1,IHIST(1)
42786         IS=INDX(ID)
42787         IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
42788           CALL PYPLOT(ID)
42789           CALL PYNULL(ID)
42790         ENDIF
42791   100 CONTINUE
42792
42793       RETURN
42794       END
42795
42796 C*********************************************************************
42797
42798 *$ CREATE PYPLOT.FOR
42799 *COPY PYPLOT
42800 C...PYPLOT
42801 C...Prints a histogram (but does not reset it).
42802
42803       SUBROUTINE PYPLOT(ID)
42804
42805 C...Double precision declaration.
42806       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42807 C...Commonblocks.
42808       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42809       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42810       SAVE /PYDAT1/,/PYBINS/
42811 C...Local arrays and character variables.
42812       DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
42813       CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
42814
42815 C...Steps in histogram scale. Character sequence.
42816       DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
42817       DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
42818
42819 C...Find initial address in memory; skip if empty histogram.
42820       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42821       IS=INDX(ID)
42822       IF(IS.EQ.0) RETURN
42823       IF(NINT(BIN(IS+5)).LE.0) THEN
42824         WRITE(MSTU(11),5000) ID
42825         RETURN
42826       ENDIF
42827
42828 C...Number of histogram lines and x bins.
42829       LIN=IHIST(3)-18
42830       NX=NINT(BIN(IS+1))
42831
42832 C...Extract title by conversion from double precision via integer.
42833       DO 100 IT=1,20
42834         IEQ=NINT(BIN(IS+8+NX+IT))
42835         TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
42836      &  //CHAR(MOD(IEQ,256))
42837   100 CONTINUE
42838
42839 C...Find time; print title.
42840       CALL PYTIME(IDATI)
42841       IF(IDATI(1).GT.0) THEN
42842         WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
42843       ELSE
42844         WRITE(MSTU(11),5200) ID, TITLE
42845       ENDIF
42846
42847 C...Find minimum and maximum bin content.
42848       YMIN=BIN(IS+9)
42849       YMAX=BIN(IS+9)
42850       DO 110 IX=IS+10,IS+8+NX
42851         IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
42852         IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
42853   110 CONTINUE
42854
42855 C...Determine scale and step size for y axis.
42856       IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
42857         IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
42858         IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
42859         IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
42860         IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
42861         IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
42862         DELY=DYAC(1)
42863         DO 120 IDEL=1,9
42864           IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
42865   120   CONTINUE
42866         DY=DELY*10D0**IPOT
42867
42868 C...Convert bin contents to integer form; fractional fill in top row.
42869         DO 130 IX=1,NX
42870           CTA=ABS(BIN(IS+8+IX))/DY
42871           IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
42872           IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
42873   130   CONTINUE
42874         IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
42875         IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
42876
42877 C...Print histogram row by row.
42878         DO 150 IR=IRMA,IRMI,-1
42879           IF(IR.EQ.0) GOTO 150
42880           OUT=' '
42881           DO 140 IX=1,NX
42882             IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
42883             IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
42884   140     CONTINUE
42885           WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
42886   150   CONTINUE
42887
42888 C...Print sign and value of bin contents.
42889         IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
42890         OUT=' '
42891         DO 160 IX=1,NX
42892           IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
42893           IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
42894   160   CONTINUE
42895         WRITE(MSTU(11),5400) OUT
42896         DO 180 IR=4,1,-1
42897           DO 170 IX=1,NX
42898             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42899   170     CONTINUE
42900           WRITE(MSTU(11),5500) IPOT+IR-4, OUT
42901   180   CONTINUE
42902
42903 C...Print sign and value of lower bin edge.
42904         IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
42905      &  10.0001D0)-10
42906         OUT=' '
42907         DO 190 IX=1,NX
42908           IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
42909      &    OUT(IX:IX)=CHA(11)
42910           IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
42911   190   CONTINUE
42912         WRITE(MSTU(11),5600) OUT
42913         DO 210 IR=3,1,-1
42914           DO 200 IX=1,NX
42915             OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
42916   200     CONTINUE
42917           WRITE(MSTU(11),5500) IPOT+IR-3, OUT
42918   210   CONTINUE
42919       ENDIF
42920
42921 C...Calculate and print statistics.
42922       CSUM=0D0
42923       CXSUM=0D0
42924       CXXSUM=0D0
42925       DO 220 IX=1,NX
42926         CTA=ABS(BIN(IS+8+IX))
42927         X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
42928         CSUM=CSUM+CTA
42929         CXSUM=CXSUM+CTA*X
42930         CXXSUM=CXXSUM+CTA*X**2
42931   220 CONTINUE
42932       XMEAN=CXSUM/MAX(CSUM,1D-20)
42933       XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
42934       WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
42935      &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
42936
42937 C...Formats for output.
42938  5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
42939  5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
42940      &I2,':',I2/)
42941  5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
42942  5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
42943  5400 FORMAT(/8X,'Contents',3X,A100)
42944  5500 FORMAT(9X,'*10**',I2,3X,A100)
42945  5600 FORMAT(/8X,'Low edge',3X,A100)
42946  5700 FORMAT(/5X,'Entries  =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
42947      &,D12.4,6X,'Low edge  =',D12.4/5X,'All chan =',D12.4,6X,
42948      &'Rms  =',D12.4,6X,'Overflow  =',D12.4,6X,'High edge =',D12.4)
42949
42950       RETURN
42951       END
42952
42953 C*********************************************************************
42954
42955 *$ CREATE PYNULL.FOR
42956 *COPY PYNULL
42957 C...PYNULL
42958 C...Resets bin contents of a histogram.
42959
42960       SUBROUTINE PYNULL(ID)
42961
42962 C...Double precision declaration.
42963       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42964 C...Commonblock.
42965       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42966       SAVE /PYBINS/
42967
42968       IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
42969       IS=INDX(ID)
42970       IF(IS.EQ.0) RETURN
42971       DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
42972         BIN(IX)=0D0
42973   100 CONTINUE
42974
42975       RETURN
42976       END
42977
42978 C*********************************************************************
42979
42980 *$ CREATE PYDUMP.FOR
42981 *COPY PYDUMP
42982 C...PYDUMP
42983 C...Dumps histogram contents on file for reading by other program.
42984 C...Can also read back own dump.
42985
42986       SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
42987
42988 C...Double precision declaration.
42989       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42990 C...Commonblock.
42991       COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
42992       SAVE /PYBINS/
42993 C...Local arrays and character variables.
42994       DIMENSION IHI(*),ISS(100),VAL(5)
42995       CHARACTER TITLE*60,FORMAT*13
42996
42997 C...Dump all histograms that have been booked,
42998 C...including titles and ranges, one after the other.
42999       IF(MDUMP.EQ.1) THEN
43000
43001 C...Loop over histograms and find which are wanted and booked.
43002         IF(NHI.LE.0) THEN
43003           NW=IHIST(1)
43004         ELSE
43005           NW=NHI
43006         ENDIF
43007         DO 130 IW=1,NW
43008           IF(NHI.EQ.0) THEN
43009             ID=IW
43010           ELSE
43011             ID=IHI(IW)
43012           ENDIF
43013           IS=INDX(ID)
43014           IF(IS.NE.0) THEN
43015
43016 C...Write title, histogram size, filling statistics.
43017             NX=NINT(BIN(IS+1))
43018             DO 100 IT=1,20
43019               IEQ=NINT(BIN(IS+8+NX+IT))
43020               TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
43021      &        CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
43022   100       CONTINUE
43023             WRITE(LFN,5100) ID,TITLE
43024             WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
43025             WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
43026      &      BIN(IS+8)
43027
43028
43029 C...Write histogram contents, in groups of five.
43030             DO 120 IXG=1,(NX+4)/5
43031               DO 110 IXV=1,5
43032                 IX=5*IXG+IXV-5
43033                 IF(IX.LE.NX) THEN
43034                   VAL(IXV)=BIN(IS+8+IX)
43035                 ELSE
43036                   VAL(IXV)=0D0
43037                 ENDIF
43038   110         CONTINUE
43039               WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
43040   120       CONTINUE
43041
43042 C...Go to next histogram; finish.
43043           ELSEIF(NHI.GT.0) THEN
43044             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43045           ENDIF
43046   130   CONTINUE
43047
43048 C...Read back in histograms dumped MDUMP=1.
43049       ELSEIF(MDUMP.EQ.2) THEN
43050
43051 C...Read histogram number, title and range, and book.
43052   140   READ(LFN,5100,END=170) ID,TITLE
43053         READ(LFN,5200) NX,XL,XU
43054         CALL PYBOOK(ID,TITLE,NX,XL,XU)
43055         IS=INDX(ID)
43056
43057 C...Read filling statistics.
43058         READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
43059         BIN(IS+5)=DBLE(NENTRY)
43060
43061 C...Read histogram contents, in groups of five.
43062         DO 160 IXG=1,(NX+4)/5
43063           READ(LFN,5400) (VAL(IXV),IXV=1,5)
43064           DO 150 IXV=1,5
43065             IX=5*IXG+IXV-5
43066             IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
43067   150     CONTINUE
43068   160   CONTINUE
43069
43070 C...Go to next histogram; finish.
43071         GOTO 140
43072   170   CONTINUE
43073
43074 C...Write histogram contents in column format,
43075 C...convenient e.g. for GNUPLOT input.
43076       ELSEIF(MDUMP.EQ.3) THEN
43077
43078 C...Find addresses to wanted histograms.
43079         NSS=0
43080         IF(NHI.LE.0) THEN
43081           NW=IHIST(1)
43082         ELSE
43083           NW=NHI
43084         ENDIF
43085         DO 180 IW=1,NW
43086           IF(NHI.EQ.0) THEN
43087             ID=IW
43088           ELSE
43089             ID=IHI(IW)
43090           ENDIF
43091           IS=INDX(ID)
43092           IF(IS.NE.0.AND.NSS.LT.100) THEN
43093             NSS=NSS+1
43094             ISS(NSS)=IS
43095           ELSEIF(NSS.GE.100) THEN
43096             CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
43097           ELSEIF(NHI.GT.0) THEN
43098             CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
43099           ENDIF
43100   180   CONTINUE
43101
43102 C...Check that they have common number of x bins. Fix format.
43103         NX=NINT(BIN(ISS(1)+1))
43104         DO 190 IW=2,NSS
43105           IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
43106             CALL PYERRM(8,'(PYDUMP:) different number of bins')
43107             RETURN
43108           ENDIF
43109   190   CONTINUE
43110         FORMAT='(1P,000E12.4)'
43111         WRITE(FORMAT(5:7),'(I3)') NSS+1
43112
43113 C...Write histogram contents; first column x values.
43114         DO 200 IX=1,NX
43115           X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
43116           WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
43117   200   CONTINUE
43118
43119       ENDIF
43120
43121 C...Formats for output.
43122  5100 FORMAT(I5,5X,A60)
43123  5200 FORMAT(I5,1P,2D12.4)
43124  5300 FORMAT(I12,1P,3D12.4)
43125  5400 FORMAT(1P,5D12.4)
43126
43127       RETURN
43128       END
43129
43130 C*********************************************************************
43131
43132 *$ CREATE PYKCUT.FOR
43133 *COPY PYKCUT
43134 C...PYKCUT
43135 C...Dummy routine, which the user can replace in order to make cuts on
43136 C...the kinematics on the parton level before the matrix elements are
43137 C...evaluated and the event is generated. The cross-section estimates
43138 C...will automatically take these cuts into account, so the given
43139 C...values are for the allowed phase space region only. MCUT=0 means
43140 C...that the event has passed the cuts, MCUT=1 that it has failed.
43141
43142       SUBROUTINE PYKCUT(MCUT)
43143
43144 C...Double precision and integer declarations.
43145       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43146       INTEGER PYK,PYCHGE,PYCOMP
43147 C...Commonblocks.
43148       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43149       COMMON/PYINT1/MINT(400),VINT(400)
43150       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43151       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43152
43153 C...Set default value (accepting event) for MCUT.
43154       MCUT=0
43155
43156 C...Read out subprocess number.
43157       ISUB=MINT(1)
43158       ISTSB=ISET(ISUB)
43159
43160 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43161       TAU=VINT(21)
43162       YST=VINT(22)
43163       CTH=0D0
43164       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43165       TAUP=0D0
43166       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43167
43168 C...Calculate x_1, x_2, x_F.
43169       IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
43170         X1=SQRT(TAU)*EXP(YST)
43171         X2=SQRT(TAU)*EXP(-YST)
43172       ELSE
43173         X1=SQRT(TAUP)*EXP(YST)
43174         X2=SQRT(TAUP)*EXP(-YST)
43175       ENDIF
43176       XF=X1-X2
43177
43178 C...Calculate shat, that, uhat, p_T^2.
43179       SHAT=TAU*VINT(2)
43180       SQM3=VINT(63)
43181       SQM4=VINT(64)
43182       RM3=SQM3/SHAT
43183       RM4=SQM4/SHAT
43184       BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
43185       RPTS=4D0*VINT(71)**2/SHAT
43186       BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
43187       RM34=2D0*RM3*RM4
43188       RSQM=1D0+RM34
43189       RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
43190       THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
43191       UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
43192       PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
43193
43194 C...Decisions by user to be put here.
43195
43196 C...Stop program if this routine is ever called.
43197 C...You should not copy these lines to your own routine.
43198       WRITE(MSTU(11),5000)
43199       IF(PYR(0).LT.10D0) STOP
43200
43201 C...Format for error printout.
43202  5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
43203      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43204      &1X,'Execution stopped!')
43205
43206       RETURN
43207       END
43208
43209 C*********************************************************************
43210
43211 *$ CREATE PYEVWT.FOR
43212 *COPY PYEVWT
43213 C...PYEVWT
43214 C...Dummy routine, which the user can replace in order to multiply the
43215 C...standard PYTHIA differential cross-section by a process- and
43216 C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
43217 C...to generation of weighted events, with weight 1/WTXS, while for
43218 C...MSTP(142)=2 it corresponds to a modification of the underlying
43219 C...physics.
43220
43221       SUBROUTINE PYEVWT(WTXS)
43222
43223 C...Double precision and integer declarations.
43224       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43225       INTEGER PYK,PYCHGE,PYCOMP
43226 C...Commonblocks.
43227       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43228       COMMON/PYINT1/MINT(400),VINT(400)
43229       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43230       SAVE /PYDAT1/,/PYINT1/,/PYINT2/
43231
43232 C...Set default weight for WTXS.
43233       WTXS=1D0
43234
43235 C...Read out subprocess number.
43236       ISUB=MINT(1)
43237       ISTSB=ISET(ISUB)
43238
43239 C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
43240       TAU=VINT(21)
43241       YST=VINT(22)
43242       CTH=0D0
43243       IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
43244       TAUP=0D0
43245       IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
43246
43247 C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
43248       X1=VINT(41)
43249       X2=VINT(42)
43250       XF=X1-X2
43251       SHAT=VINT(44)
43252       THAT=VINT(45)
43253       UHAT=VINT(46)
43254       PT2=VINT(48)
43255
43256 C...Modifications by user to be put here.
43257
43258 C...Stop program if this routine is ever called.
43259 C...You should not copy these lines to your own routine.
43260       WRITE(MSTU(11),5000)
43261       IF(PYR(0).LT.10D0) STOP
43262
43263 C...Format for error printout.
43264  5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
43265      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43266      &1X,'Execution stopped!')
43267
43268       RETURN
43269       END
43270
43271 C*********************************************************************
43272
43273 *$ CREATE PYUPIN.FOR
43274 *COPY PYUPIN
43275 C...PYUPIN
43276 C...Dummy copy of routine to be called by user to set up a user-defined
43277 C...process.
43278
43279       SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX)
43280
43281 C...Double precision and integer declarations.
43282       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43283       INTEGER PYK,PYCHGE,PYCOMP
43284 C...Commonblocks.
43285       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43286       COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43287       COMMON/PYINT6/PROC(0:500)
43288       CHARACTER PROC*28
43289       SAVE /PYDAT1/,/PYINT2/,/PYINT6/
43290 C...Local character variable.
43291       CHARACTER*(*) TITLE
43292
43293 C...Check that subprocess number free.
43294       IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN
43295         WRITE(MSTU(11),5000) ISUB
43296         STOP
43297       ENDIF
43298
43299 C...Fill information on new process.
43300       ISET(ISUB)=11
43301       COEF(ISUB,1)=SIGMAX
43302       PROC(ISUB)=TITLE//' '
43303
43304 C...Format for error output.
43305  5000 FORMAT(1X,'Error: user-defined subprocess code ',I4,
43306      &' not allowed.'//1X,'Execution stopped!')
43307
43308       RETURN
43309       END
43310
43311 C*********************************************************************
43312
43313 *$ CREATE PYUPEV.FOR
43314 *COPY PYUPEV
43315 C...PYUPEV
43316 C...Dummy routine, to be replaced by user. When called from PYTHIA
43317 C...the subprocess number ISUB will be given, and PYUPEV is supposed
43318 C...to generate an event of this type, to be stored in the PYUPPR
43319 C...commonblock. SIGEV gives the differential cross-section associated
43320 C...with the event, i.e. the acceptance probability of the event is
43321 C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN
43322 C...call.
43323
43324       SUBROUTINE PYUPEV(ISUB,SIGEV)
43325
43326 C...Double precision and integer declarations.
43327       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43328       INTEGER PYK,PYCHGE,PYCOMP
43329 C...Commonblocks.
43330       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43331       COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10)
43332       SAVE /PYDAT1/,/PYUPPR/
43333
43334 C...Stop program if this routine is ever called.
43335 C...You should not copy these lines to your own routine.
43336       WRITE(MSTU(11),5000)
43337       IF(PYR(0).LT.10D0) STOP
43338       SIGEV=ISUB
43339
43340 C...Format for error printout.
43341  5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ',
43342      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43343      &1X,'Execution stopped!')
43344
43345       RETURN
43346       END
43347
43348 C*********************************************************************
43349
43350 *$ CREATE PYTAUD.FOR
43351 *COPY PYTAUD
43352 C...PYTAUD
43353 C...Dummy routine, to be replaced by user, to handle the decay of a
43354 C...polarized tau lepton.
43355 C...Input:
43356 C...ITAU is the position where the decaying tau is stored in /PYJETS/.
43357 C...IORIG is the position where the mother of the tau is stored;
43358 C...     is 0 when the mother is not stored.
43359 C...KFORIG is the flavour of the mother of the tau;
43360 C...     is 0 when the mother is not known.
43361 C...Note that IORIG=0 does not necessarily imply KFORIG=0;
43362 C...     e.g. in B hadron semileptonic decays the W  propagator
43363 C...     is not explicitly stored but the W code is still unambiguous.
43364 C...Output:
43365 C...NDECAY is the number of decay products in the current tau decay.
43366 C...These decay products should be added to the /PYJETS/ common block,
43367 C...in positions N+1 through N+NDECAY. For each product I you must
43368 C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
43369 C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
43370
43371       SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
43372
43373 C...Double precision and integer declarations.
43374       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43375       INTEGER PYK,PYCHGE,PYCOMP
43376 C...Commonblocks.
43377       COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
43378       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43379       SAVE /PYJETS/,/PYDAT1/
43380
43381 C...Stop program if this routine is ever called.
43382 C...You should not copy these lines to your own routine.
43383       NDECAY=ITAU+IORIG+KFORIG
43384       WRITE(MSTU(11),5000)
43385       IF(PYR(0).LT.10D0) STOP
43386
43387 C...Format for error printout.
43388  5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
43389      &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
43390      &1X,'Execution stopped!')
43391
43392       RETURN
43393       END
43394
43395 C*********************************************************************
43396
43397 *$ CREATE PYTIME.FOR
43398 *COPY PYTIME
43399 C...PYTIME
43400 C...Finds current date and time.
43401 C...Since this task is not standardized in Fortran 77, the routine
43402 C...is dummy, to be replaced by the user. Examples are given for
43403 C...the Fortran 90 routine and DEC Fortran 77, and what to do if
43404 C...you do not have access to suitable routines.
43405
43406       SUBROUTINE PYTIME(IDATI)
43407
43408 C...Double precision and integer declarations.
43409       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43410       INTEGER PYK,PYCHGE,PYCOMP
43411       CHARACTER*8 ATIME
43412 C...Local array.
43413       INTEGER IDATI(6),IDTEMP(3)
43414
43415 C...Example 0: if you do not have suitable routines.
43416       DO 100 J=1,6
43417       IDATI(J)=0
43418   100 CONTINUE
43419
43420 C...Example 1: Fortran 90 routine.
43421 C      INTEGER IVAL(8)
43422 C      CALL DATE_AND_TIME(VALUES=IVAL)
43423 C      IDATI(1)=IVAL(1)
43424 C      IDATI(2)=IVAL(2)
43425 C      IDATI(3)=IVAL(3)
43426 C      IDATI(4)=IVAL(5)
43427 C      IDATI(5)=IVAL(6)
43428 C      IDATI(6)=IVAL(7)
43429
43430 C...Example 2: DEC Fortran 77.
43431 C      CALL IDATE(IMON,IDAY,IYEAR)
43432 C      IDATI(1)=1900+IYEAR
43433 C      IDATI(2)=IMON
43434 C      IDATI(3)=IDAY
43435 C      CALL ITIME(IHOUR,IMIN,ISEC)
43436 C      IDATI(4)=IHOUR
43437 C      IDATI(5)=IMIN
43438 C      IDATI(6)=ISEC
43439
43440 C...Example 3: DEC Fortran
43441 C      CALL IDATE(IMON,IDAY,IYEAR)
43442 C      IDATI(1)=1900+IYEAR
43443 C      IDATI(2)=IMON
43444 C      IDATI(3)=IDAY
43445 C      CALL TIME(ATIME)
43446 C      IHOUR=0
43447 C      IMIN=0
43448 C      ISEC=0
43449 C      READ(ATIME(1:2),'(I2)') IHOUR
43450 C      READ(ATIME(4:5),'(I2)') IMIN
43451 C      READ(ATIME(7:8),'(I2)') ISEC
43452 C      IDATI(4)=IHOUR
43453 C      IDATI(5)=IMIN
43454 C      IDATI(6)=ISEC
43455
43456 C...Example 4: GNU LINUX libU77.
43457 C      CALL IDATE(IDTEMP)
43458 C      IDATI(1)=IDTEMP(3)
43459 C      IDATI(2)=IDTEMP(2)
43460 C      IDATI(3)=IDTEMP(1)
43461 C      CALL ITIME(IDTEMP)
43462 C      IDATI(4)=IDTEMP(1)
43463 C      IDATI(5)=IDTEMP(2)
43464 C      IDATI(6)=IDTEMP(3)
43465
43466       RETURN
43467       END