9.6.p02/html/pythia61_8f_source.html

C*********************************************************************

C*********************************************************************

C*                                                                  **

C*                                                    March 1997    **

C*                                                                  **

C*           The Lund Monte Carlo for Hadronic Processes            **

C*                                                                  **

C*                        PYTHIA version 6.1                        **

C*                                                                  **

C*                        Torbjorn Sjostrand                        **

C*                Department of Theoretical Physics 2               **

C*                         Lund University                          **

C*               Solvegatan 14A, S-223 62 Lund, Sweden              **

C*                    phone +46 - 46 - 222 48 16                    **

C*                    E-mail torbjorn@thep.lu.se                    **

C*                                                                  **

C*                          SUSY parts by                           **

C*                         Stephen Mrenna                           **

C*                    Argonne National Laboratory                   **

C*          9700 South Cass Avenue, Argonne, IL 60439, USA          **

C*                   phone + 1 - 630 - 252 - 7615                   **

C*                    E-mail mrenna@hep.anl.gov                     **

C*                                                                  **

C*         Several parts are written by Hans-Uno Bengtsson          **

C*          PYSHOW is written together with Mats Bengtsson          **

C*     CTEQ 3 parton distributions are by the CTEQ collaboration    **

C*      GRV 94 parton distributions are by Glueck, Reya and Vogt    **

C*   SaS photon parton distributions together with Gerhard Schuler  **

C*     g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt     **

C*         MSSM Higgs mass calculation code by M. Carena,           **

C*           J.R. Espinosa, M. Quiros and C.E.M. Wagner             **

C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **

C*                                                                  **

C*   The latest program version and documentation is found on WWW   **

C*         http://thep.lu.se/tf2/staff/torbjorn/Pythia.html         **

C*                                                                  **

C*              Copyright Torbjorn Sjostrand, Lund 1997             **

C*                                                                  **

C*********************************************************************

C*********************************************************************

C                                                                    *

C  List of subprograms in order of appearance, with main purpose     *

C  (S = subroutine, F = function, B = block data)                    *

C                                                                    *

C  B   PYDATA   to contain all default values                        *

C  S   PYTEST   to test the proper functioning of the package        *

C  S   PYHEPC   to convert between /PYJETS/ and /HEPEVT/ records     *

C                                                                    *

C  S   PYINIT   to administer the initialization procedure           *

C  S   PYEVNT   to administer the generation of an event             *

C  S   PYSTAT   to print cross-section and other information         *

C  S   PYINRE   to initialize treatment of resonances                *

C  S   PYINBM   to read in beam, target and frame choices            *

C  S   PYINKI   to initialize kinematics of incoming particles       *

C  S   PYINPR   to set up the selection of included processes        *

C  S   PYXTOT   to give total, elastic and diffractive cross-sect.   *

C  S   PYMAXI   to find differential cross-section maxima            *

C  S   PYPILE   to select multiplicity of pileup events              *

C  S   PYSAVE   to save alternatives for gamma-p and gamma-gamma     *

C  S   PYRAND   to select subprocess and kinematics for event        *

C  S   PYSCAT   to set up kinematics and colour flow of event        *

C  S   PYSSPA   to simulate initial state spacelike showers          *

C  S   PYRESD   to perform resonance decays                          *

C  S   PYMULT   to generate multiple interactions                    *

C  S   PYREMN   to add on target remnants                            *

C  S   PYDIFF   to set up kinematics for diffractive events          *

C  S   PYDOCU   to compute cross-sections and handle documentation   *

C  S   PYFRAM   to perform boosts between different frames           *

C  S   PYWIDT   to calculate full and partial widths of resonances   *

C  S   PYOFSH   to calculate partial width into off-shell channels   *

C  S   PYRECO   to handle colour reconnection in W+W- events         *

C  S   PYKLIM   to calculate borders of allowed kinematical region   *

C  S   PYKMAP   to construct value of kinematical variable           *

C  S   PYSIGH   to calculate differential cross-sections             *

C  S   PYPDFU   to evaluate parton distributions                     *

C  S   PYPDFL   to evaluate parton distributions at low x and Q^2    *

C  S   PYPDEL   to evaluate electron parton distributions            *

C  S   PYPDGA   to evaluate photon parton distributions (generic)    *

C  S   PYGGAM   to evaluate photon parton distributions (SaS sets)   *

C  S   PYGVMD   to evaluate VMD part of photon parton distributions  *

C  S   PYGANO   to evaluate anomalous part of photon pdf's           *

C  S   PYGBEH   to evaluate Bethe-Heitler part of photon pdf's       *

C  S   PYGDIR   to evaluate direct contribution to photon pdf's      *

C  S   PYPDPI   to evaluate pion parton distributions                *

C  S   PYPDPR   to evaluate proton parton distributions              *

C  F   PYCTEQ   to evaluate the CTEQ 3 proton parton distributions   *

C  S   PYGRVL   to evaluate the GRV 94L pronton parton distributions *

C  S   PYGRVM   to evaluate the GRV 94M pronton parton distributions *

C  S   PYGRVD   to evaluate the GRV 94D pronton parton distributions *

C  F   PYGRVV   auxiliary to the PYGRV* routines                     *

C  F   PYGRVW   auxiliary to the PYGRV* routines                     *

C  F   PYGRVS   auxiliary to the PYGRV* routines                     *

C  F   PYHFTH   to evaluate threshold factor for heavy flavour       *

C  S   PYSPLI   to find flavours left in hadron when one removed     *

C  F   PYGAMM   to evaluate ordinary Gamma function Gamma(x)         *

C  S   PYWAUX   to evaluate auxiliary functions W1(s) and W2(s)      *

C  S   PYI3AU   to evaluate auxiliary function I3(s,t,u,v)           *

C  F   PYSPEN   to evaluate Spence (dilogarithm) function Sp(x)      *

C  S   PYQQBH   to evaluate matrix element for g + g -> Q + Qbar + H *

C                                                                    *

C  S   PYMSIN   to initialize the supersymmetry simulation           *

C  S   PYAPPS   to determine MSSM parameters from SUGRA input        *

C  F   PYRNMQ   to determine running quark masses                    *

C  F   PYRNMT   to determine running top mass                        *

C  S   PYTHRG   to calculate sfermion third-gen. mass eigenstates    *

C  S   PYINOM   to calculate neutralino/chargino mass eigenstates    *

C  F   PYRNM3   to determine running M3, gluino mass                 *

C  S   PYEIG4   to calculate eigenvalues and -vectors in 4*4 matrix  *

C  S   PYHGGM   to determine Higgs mass spectrum                     *

C  S   PYSUBH   to determine Higgs masses in the MSSM                *

C  S   PYPOLE   to determine Higgs masses in the MSSM                *

C  S   PYVACU   to determine Higgs masses in the MSSM                *

C  S   PYRGHM   auxiliary to PYVACU                                  *

C  S   PYGFXX   auxiliary to PYRGHM                                  *

C  F   PYFINT   auxiliary to PYVACU                                  *

C  F   PYFISB   auxiliary to PYFINT                                  *

C  S   PYSFDC   to calculate sfermion decay partial widths           *

C  S   PYGLUI   to calculate gluino decay partial widths             *

C  S   PYTBBN   to calculate 3-body decay of gluino to neutralino    *

C  S   PYTBBC   to calculate 3-body decay of gluino to chargino      *

C  S   PYNJDC   to calculate neutralino decay partial widths         *

C  S   PYCJDC   to calculate chargino decay partial widths           *

C  F   PYXXZ5   auxiliary for neutralino 3-body decay                *

C  F   PYXXW5   auxiliary for ino charge change 3-body decay         *

C  F   PYXXGA   auxiliary for ino -> ino + gamma decay               *

C  F   PYX2XG   auxiliary for ino -> ino + gauge boson decay         *

C  F   PYX2XH   auxiliary for ino -> ino + Higgs decay               *

C  F   PYXXZ2   auxiliary for chargino 3-body decay                  *

C  S   PYHEXT   to calculate non-SM Higgs decay partial widths       *

C  F   PYH2XX   auxiliary for H -> ino + ino decay                   *

C  F   PYGAUS   to perform Gaussian integration                      *

C  F   PYSIMP   to perform Simpson integration                       *

C  F   PYLAMF   to evaluate the lambda kinematics function           *

C  S   PYTBDY   to perform 3-body decay of gauginos                  *

C                                                                    *

C  S   PY1ENT   to fill one entry (= parton or particle)             *

C  S   PY2ENT   to fill two entries                                  *

C  S   PY3ENT   to fill three entries                                *

C  S   PY4ENT   to fill four entries                                 *

C  S   PYJOIN   to connect entries with colour flow information      *

C  S   PYGIVE   to fill (or query) commonblock variables             *

C  S   PYEXEC   to administrate fragmentation and decay chain        *

C  S   PYPREP   to rearrange showered partons along strings          *

C  S   PYSTRF   to do string fragmentation of jet system             *

C  S   PYINDF   to do independent fragmentation of one or many jets  *

C  S   PYDECY   to do the decay of a particle                        *

C  S   PYKFDI   to select parton and hadron flavours in fragm        *

C  S   PYPTDI   to select transverse momenta in fragm                *

C  S   PYZDIS   to select longitudinal scaling variable in fragm     *

C  S   PYSHOW   to do timelike parton shower evolution               *

C  S   PYBOEI   to include Bose-Einstein effects (crudely)           *

C  F   PYMASS   to give the mass of a particle or parton             *

C  S   PYNAME   to give the name of a particle or parton             *

C  F   PYCHGE   to give three times the electric charge              *

C  F   PYCOMP   to compress standard KF flavour code to internal KC  *

C  S   PYERRM   to write error messages and abort faulty run         *

C  F   PYALEM   to give the alpha_electromagnetic value              *

C  F   PYALPS   to give the alpha_strong value                       *

C  F   PYANGL   to give the angle from known x and y components      *

C  F   PYR      to provide a random number generator                 *

C  S   PYRGET   to save the state of the random number generator     *

C  S   PYRSET   to set the state of the random number generator      *

C  S   PYROBO   to rotate and/or boost an event                      *

C  S   PYEDIT   to remove unwanted entries from record               *

C  S   PYLIST   to list event record or particle data                *

C  S   PYLOGO   to write a logo                                      *

C  S   PYUPDA   to update particle data                              *

C  F   PYK      to provide integer-valued event information          *

C  F   PYP      to provide real-valued event information             *

C  S   PYSPHE   to perform sphericity analysis                       *

C  S   PYTHRU   to perform thrust analysis                           *

C  S   PYCLUS   to perform three-dimensional cluster analysis        *

C  S   PYCELL   to perform cluster analysis in (eta, phi, E_T)       *

C  S   PYJMAS   to give high and low jet mass of event               *

C  S   PYFOWO   to give Fox-Wolfram moments                          *

C  S   PYTABU   to analyze events, with tabular output               *

C                                                                    *

C  S   PYEEVT   to administrate the generation of an e+e- event      *

C  S   PYXTEE   to give the total cross-section at given CM energy   *

C  S   PYRADK   to generate initial state photon radiation           *

C  S   PYXKFL   to select flavour of primary qqbar pair              *

C  S   PYXJET   to select (matrix element) jet multiplicity          *

C  S   PYX3JT   to select kinematics of three-jet event              *

C  S   PYX4JT   to select kinematics of four-jet event               *

C  S   PYXDIF   to select angular orientation of event               *

C  S   PYONIA   to perform generation of onium decay to gluons       *

C                                                                    *

C  S   PYBOOK   to book a histogram                                  *

C  S   PYFILL   to fill an entry in a histogram                      *

C  S   PYFACT   to multiply histogram contents by a factor           *

C  S   PYOPER   to perform operations between histograms             *

C  S   PYHIST   to print and reset all histograms                    *

C  S   PYPLOT   to print a single histogram                          *

C  S   PYNULL   to reset contents of a single histogram              *

C  S   PYDUMP   to dump histogram contents onto a file               *

C                                                                    *

C  S   PYKCUT   dummy routine for user kinematical cuts              *

C  S   PYEVWT   dummy routine for weighting events                   *

C  S   PYUPIN   dummy routine to initialize a user process           *

C  S   PYUPEV   dummy routine to generate a user process event       *

C  S   PDFSET   dummy routine to be removed when using PDFLIB        *

C  S   STRUCTM  dummy routine to be removed when using PDFLIB        *

C  S   PYTAUD   dummy routine for interface to tau decay libraries   *

C  S   PYTIME   dummy routine for giving date and time               *

C                                                                    *

C*********************************************************************


C...PYDATA

C...Default values for switches and parameters,

C...and particle, decay and process data.


      BLOCK DATA pydata


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      common/pydatr/mrpy(6),rrpy(100)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      common/pyint7/sigt(0:6,0:6,0:5)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,/pysubs/,

     &/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,

     &/pyint6/,/pyint7/,/pymssm/,/pyssmt/,/pybins/


C...PYDAT1, containing status codes and most parameters.

      DATA mstu/

     &   0,    0,    0, 4000,10000,  500, 4000,    0,    0,    2,

     1   6,    1,    1,    0,    1,    1,    0,    0,    0,    0,

     2   2,   10,    0,    0,    1,   10,    0,    0,    0,    0,

     3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     4   2,    2,    1,    4,    2,    1,    1,    0,    0,    0,

     5  25,   24,    0,    1,    0,    0,    0,    0,    0,    0,

     6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     7  30*0,

     1   1,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     2   1,    5,    3,    5,    0,    0,    0,    0,    0,    0,

     &  80*0/

      DATA paru/

     &  3.141592653589793d0, 6.283185307179586d0,

     &  0.197327d0, 5.06773d0, 0.389380d0, 2.56819d0,  4*0d0,

     1  0.001d0, 0.09d0, 0.01d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0, 0d0,

     2  0d0,   0d0,   0d0,   0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,

     3  0d0,   0d0,   0d0,   0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,

     4  2.0d0,  1.0d0, 0.25d0,  2.5d0, 0.05d0,

     4  0d0,   0d0, 0.0001d0, 0d0,   0d0,

     5  2.5d0,1.5d0,7.0d0,1.0d0,0.5d0,2.0d0,3.2d0, 0d0, 0d0, 0d0,

     6  40*0d0,

     &  0.00729735d0, 0.232d0, 0.007764d0, 1.0d0, 1.16639d-5,

     &  0d0, 0d0, 0d0, 0d0,  0d0,

     1  0.20d0, 0.25d0, 1.0d0, 4.0d0, 10d0, 0d0, 0d0,  0d0, 0d0, 0d0,

     2 -0.693d0, -1.0d0, 0.387d0, 1.0d0, -0.08d0,

     2 -1.0d0,  1.0d0,  1.0d0,  1.0d0,  0d0,

     3  1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0,  0d0,  0d0, 0d0, 0d0, 0d0,

     4  5.0d0, 1.0d0, 1.0d0,  0d0, 1.0d0, 1.0d0,  0d0, 0d0, 0d0, 0d0,

     5  1.0d0, 0d0, 0d0, 0d0, 1000d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0,0d0,

     6  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0,  0d0,  0d0, 0d0, 0d0, 0d0,

     7  1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,

     8  1.0d0, 1.0d0, 1.0d0, 0.0d0, 0.0d0, 1.0d0, 1.0d0, 0d0,0d0,0d0,

     9  0d0,  0d0,  0d0,  0d0, 1.0d0,  0d0,  0d0, 0d0, 0d0, 0d0/

      DATA mstj/

     &  1,    3,    0,    0,    0,    0,    0,    0,    0,    0,

     1  4,    2,    0,    1,    0,    0,    0,    0,    0,    0,

     2  2,    1,    1,    2,    1,    2,    2,    0,    0,    0,

     3  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     4  2,    2,    4,    2,    5,    3,    3,    0,    0,    3,

     5  0,    3,    0,    0,    0,    0,    0,    0,    0,    0,

     6  40*0,

     &  5,    2,    7,    5,    1,    1,    0,    2,    0,    2,

     1  0,    0,    0,    0,    1,    1,    0,    0,    0,    0,

     2  80*0/

      DATA parj/

     &  0.10d0, 0.30d0, 0.40d0, 0.05d0, 0.50d0,

     &  0.50d0, 0.50d0,   0d0,   0d0,   0d0,

     1  0.50d0,0.60d0,0.75d0, 0d0, 0d0, 0d0, 0d0, 1.0d0, 1.0d0, 0d0,

     2  0.36d0, 1.0d0,0.01d0, 2.0d0,1.0d0,0.4d0, 0d0, 0d0, 0d0, 0d0,

     3  0.10d0, 1.0d0, 0.8d0, 1.5d0,0d0,2.0d0,0.2d0,2.5d0,0.6d0,0d0,

     4  0.3d0, 0.58d0, 0.5d0, 0.9d0,0.5d0,1.0d0,1.0d0,1.0d0,0d0,0d0,

     5  0.77d0, 0.77d0, 0.77d0, -0.05d0, -0.005d0,

     5 -0.00001d0, -0.00001d0, -0.00001d0, 1.0d0, 0d0,

     6  4.5d0, 0.7d0, 0d0,0.003d0, 0.5d0, 0.5d0, 0d0, 0d0, 0d0, 0d0,

     7  10d0, 1000d0, 100d0, 1000d0, 0d0, 0.7d0,10d0, 0d0, 0d0, 0d0,

     8  0.29d0, 1.0d0, 1.0d0,  0d0,  10d0, 10d0, 0d0, 0d0, 0d0, 0d0,

     9  0.02d0, 1.0d0, 0.2d0,  0d0,  0d0,  0d0,  0d0, 0d0, 0d0, 0d0,

     &  0d0,  0d0,  0d0,  0d0,   0d0,   0d0,  0d0,  0d0,  0d0,  0d0,

     1  0d0,  0d0,  0d0,  0d0,   0d0,   0d0,  0d0,  0d0,  0d0,  0d0,

     2  1.0d0, 0.25d0,91.187d0,2.489d0, 0.01d0,

     2  2.0d0,  1.0d0, 0.25d0,0.002d0,   0d0,

     3  0d0, 0d0, 0d0, 0d0, 0.01d0, 0.99d0, 0d0, 0d0,  0.2d0,   0d0,

     4  60*0d0/


C...PYDAT2, with particle data and flavour treatment parameters.

      DATA (kchg(i,1),i=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,

     &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3,

     &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,

     &6,2*-2,2*-3,0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,

     &3,2*1,2*0,2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,

     &3,2*-2,2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,

     &-3,2*0,2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,

     &3,0,3,2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,

     &2,-1,2,-1,2,-3,0,-3,0,-3,0,-1,2,-3,164*0/

      DATA (kchg(i,2),i=   1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1,

     &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,

     &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,

     &6*1,6*0,2*1,165*0/

      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,

     &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,

     &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,

     &3*0,12*1,3*0,1,2*0,1,0,16*1,163*0/

      DATA (kchg(i,4),i=   1, 293)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,

     &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,

     &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,

     &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,

     &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,

     &100,110,111,113,115,130,210,211,213,215,220,221,223,225,310,311,

     &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431,

     &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541,

     &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210,

     &2212,2214,2224,3101,3103,3112,3114,3122,3201,3203,3212,3214,3222,

     &3224,3303,3312,3314,3322,3324,3334,4101,4103,4112,4114,4122,4132,

     &4201,4203,4212,4214,4222,4224,4232,4301,4303,4312,4314,4322,4324,

     &4332,4334,4403,4412,4414,4422,4424,4432,4434,4444,5101,5103,5112,

     &5114,5122,5132,5142,5201,5203,5212,5214,5222,5224,5232,5242,5301,

     &5303,5312,5314,5322,5324,5332,5334,5342,5401,5403,5412,5414,5422,

     &5424,5432,5434,5442,5444,5503,5512,5514,5522,5524,5532,5534,5542,

     &5544,5554,10111,10113,10211,10213,10221,10223,10311,10313,10321,

     &10323,10331,10333,10411,10413,10421,10423,10431,10433,10441,

     &10443,10511,10513,10521,10523,10531,10533,10541,10543,10551,

     &10553,20113,20213,20223,20313,20323,20333,20413,20423,20433/

      DATA (kchg(i,4),i= 294, 500)/20443,20513,20523,20533,20543,20553,

     &100443,100553,1000001,1000002,1000003,1000004,1000005,1000006,

     &1000011,1000012,1000013,1000014,1000015,1000016,1000021,1000022,

     &1000023,1000024,1000025,1000035,1000037,1000039,2000001,2000002,

     &2000003,2000004,2000005,2000006,2000011,2000012,2000013,2000014,

     &2000015,2000016,4000001,4000002,4000011,4000012,163*0/

      DATA (pmas(i,1),i=   1, 214)/0.0099d0,0.0056d0,0.199d0,1.35d0,

     &5d0,175d0,2*400d0,2*0d0,0.00051d0,0d0,0.10566d0,0d0,1.777d0,0d0,

     &400d0,5*0d0,91.187d0,80.33d0,80d0,6*0d0,500d0,900d0,500d0,

     &3*300d0,350d0,200d0,5000d0,10*0d0,3*100d0,3*200d0,26*0d0,1d0,2d0,

     &5d0,16*0d0,0.13498d0,0.7685d0,1.318d0,0.49767d0,0d0,0.13957d0,

     &0.7669d0,1.318d0,0d0,0.54745d0,0.78194d0,1.275d0,2*0.49767d0,

     &0.8961d0,1.432d0,0.4936d0,0.8916d0,1.425d0,0d0,0.95777d0,

     &1.0194d0,1.525d0,1.8693d0,2.01d0,2.46d0,1.8645d0,2.0067d0,2.46d0,

     &1.9685d0,2.1124d0,2.5735d0,0d0,2.9798d0,3.09688d0,3.5562d0,

     &5.2792d0,5.3248d0,5.83d0,5.2789d0,5.3248d0,5.83d0,5.3693d0,

     &5.4163d0,6.07d0,6.594d0,6.602d0,7.35d0,9.4d0,9.4603d0,9.9132d0,

     &0.77133d0,1.234d0,0.57933d0,0.77133d0,0d0,0.93957d0,1.233d0,

     &0.77133d0,0d0,0.93827d0,1.232d0,1.231d0,0.80473d0,0.92953d0,

     &1.19744d0,1.3872d0,1.11568d0,0.80473d0,0.92953d0,1.19255d0,

     &1.3837d0,1.18937d0,1.3828d0,1.09361d0,1.3213d0,1.535d0,1.3149d0,

     &1.5318d0,1.67245d0,1.96908d0,2.00808d0,2.4521d0,2.5d0,2.2849d0,

     &2.4703d0,1.96908d0,2.00808d0,2.4535d0,2.5d0,2.4529d0,2.5d0,

     &2.4656d0,2.15432d0,2.17967d0,2.55d0,2.63d0,2.55d0,2.63d0,2.704d0,

     &2.8d0,3.27531d0,3.59798d0,3.65648d0,3.59798d0,3.65648d0,

     &3.78663d0,3.82466d0,4.91594d0,5.38897d0,5.40145d0,5.8d0,5.81d0/

      DATA (pmas(i,1),i= 215, 500)/5.641d0,5.84d0,7.00575d0,5.38897d0,

     &5.40145d0,5.8d0,5.81d0,5.8d0,5.81d0,5.84d0,7.00575d0,5.56725d0,

     &5.57536d0,5.96d0,5.97d0,5.96d0,5.97d0,6.12d0,6.13d0,7.19099d0,

     &6.67143d0,6.67397d0,7.03724d0,7.0485d0,7.03724d0,7.0485d0,

     &7.21101d0,7.219d0,8.30945d0,8.31325d0,10.07354d0,10.42272d0,

     &10.44144d0,10.42272d0,10.44144d0,10.60209d0,10.61426d0,

     &11.70767d0,11.71147d0,15.11061d0,0.9835d0,1.231d0,0.9835d0,

     &1.231d0,1d0,1.17d0,1.429d0,1.29d0,1.429d0,1.29d0,2*1.4d0,2.272d0,

     &2.424d0,2.272d0,2.424d0,2.5d0,2.536d0,3.4151d0,3.46d0,5.68d0,

     &5.73d0,5.68d0,5.73d0,5.92d0,5.97d0,7.25d0,7.3d0,9.8598d0,9.875d0,

     &2*1.23d0,1.282d0,2*1.402d0,1.427d0,2*2.372d0,2.56d0,3.5106d0,

     &2*5.78d0,6.02d0,7.3d0,9.8919d0,3.686d0,10.0233d0,32*500d0,

     &4*400d0,163*0d0/

      DATA (pmas(i,2),i=   1, 500)/5*0d0,1.4d0,16*0d0,2.47833d0,

     &2.069d0,0.00295d0,6*0d0,14.67788d0,0d0,16.79392d0,8.45231d0,

     &4.93534d0,5.80468d0,19.1898d0,0.39162d0,417.35283d0,62*0d0,

     &0.151d0,0.107d0,3*0d0,0.149d0,0.107d0,2*0d0,0.00843d0,0.185d0,

     &2*0d0,0.0505d0,0.109d0,0d0,0.0498d0,0.098d0,0d0,0.0002d0,

     &0.00443d0,0.076d0,2*0d0,0.023d0,2*0d0,0.023d0,2*0d0,0.015d0,0d0,

     &0.0013d0,0d0,0.002d0,2*0d0,0.02d0,2*0d0,0.02d0,2*0d0,0.02d0,

     &2*0d0,0.02d0,4*0d0,0.12d0,4*0d0,0.12d0,3*0d0,2*0.12d0,3*0d0,

     &0.0394d0,4*0d0,0.036d0,0d0,0.0358d0,2*0d0,0.0099d0,0d0,0.0091d0,

     &74*0d0,0.06d0,0.142d0,0.06d0,0.142d0,0d0,0.36d0,0.287d0,0.09d0,

     &0.287d0,0.09d0,0.25d0,0.08d0,0.05d0,0.02d0,0.05d0,0.02d0,0.05d0,

     &0d0,0.014d0,0.01d0,8*0.05d0,0d0,0.01d0,2*0.4d0,0.025d0,2*0.174d0,

     &0.053d0,3*0.05d0,0.0009d0,4*0.05d0,3*0d0,19*1d0,0d0,7*1d0,0d0,

     &1d0,0d0,1d0,0d0,2.60511d0,2.60839d0,0.42904d0,0.41921d0,163*0d0/

      DATA (pmas(i,3),i=   1, 500)/5*0d0,14d0,16*0d0,24.78326d0,

     &20.69d0,0.02954d0,6*0d0,146.77876d0,0d0,167.93924d0,84.52308d0,

     &49.35344d0,58.04675d0,191.89803d0,3.91624d0,4173.5283d0,62*0d0,

     &0.4d0,0.25d0,3*0d0,0.4d0,0.25d0,2*0d0,0.1d0,0.17d0,2*0d0,0.2d0,

     &0.12d0,0d0,0.2d0,0.12d0,0d0,0.002d0,0.015d0,0.2d0,2*0d0,0.12d0,

     &2*0d0,0.12d0,2*0d0,0.05d0,0d0,0.005d0,0d0,0.01d0,2*0d0,0.05d0,

     &2*0d0,0.05d0,2*0d0,0.05d0,2*0d0,0.05d0,4*0d0,0.14d0,4*0d0,0.14d0,

     &3*0d0,2*0.14d0,3*0d0,0.04d0,4*0d0,0.035d0,0d0,0.035d0,2*0d0,

     &0.05d0,0d0,0.05d0,74*0d0,0.05d0,0.25d0,0.05d0,0.25d0,0d0,0.2d0,

     &0.4d0,0.005d0,0.4d0,0.01d0,0.35d0,0.001d0,0.1d0,0.08d0,0.1d0,

     &0.08d0,0.1d0,0d0,0.05d0,0.02d0,6*0.1d0,0.05d0,0.1d0,0d0,0.02d0,

     &2*0.3d0,0.05d0,2*0.3d0,0.02d0,2*0.1d0,0.03d0,0.001d0,4*0.1d0,

     &3*0d0,19*10d0,0.00001d0,7*10d0,0.00001d0,10d0,0.00001d0,10d0,

     &0.00001d0,26.05109d0,26.08388d0,4.29043d0,4.19206d0,163*0d0/

      DATA (pmas(i,4),i=   1, 500)/12*0d0,658654d0,0d0,0.0872d0,68*0d0,

     &0.1d0,0.387d0,16*0d0,0.00003d0,2*0d0,15500d0,0d0,7804.5d0,6*0d0,

     &26.762d0,3*0d0,3709d0,6*0d0,0.317d0,2*0d0,0.1244d0,2*0d0,0.14d0,

     &6*0d0,0.468d0,2*0d0,0.462d0,2*0d0,0.483d0,2*0d0,0.15d0,19*0d0,

     &44.34d0,0d0,78.88d0,4*0d0,23.96d0,2*0d0,49.1d0,0d0,87.1d0,0d0,

     &24.6d0,4*0d0,0.0618d0,0.029d0,6*0d0,0.106d0,6*0d0,0.019d0,2*0d0,

     &7*0.1d0,4*0d0,0.342d0,2*0.387d0,6*0d0,2*0.387d0,6*0d0,0.387d0,

     &0d0,0.387d0,2*0d0,8*0.387d0,0d0,9*0.387d0,83*0d0,163*0d0/

      DATA parf/

     &  0.5d0,0.25d0, 0.5d0,0.25d0, 1d0, 0.5d0,  0d0,  0d0,  0d0, 0d0,

     1  0.5d0,  0d0, 0.5d0,  0d0,  1d0,  1d0,  0d0,  0d0,  0d0, 0d0,

     2  0.5d0,  0d0, 0.5d0,  0d0,  1d0,  1d0,  0d0,  0d0,  0d0, 0d0,

     3  0.5d0,  0d0, 0.5d0,  0d0,  1d0,  1d0,  0d0,  0d0,  0d0, 0d0,

     4  0.5d0,  0d0, 0.5d0,  0d0,  1d0,  1d0,  0d0,  0d0,  0d0, 0d0,

     5  0.5d0,  0d0, 0.5d0,  0d0,  1d0,  1d0,  0d0,  0d0,  0d0, 0d0,

     6  0.75d0, 0.5d0, 0d0,0.1667d0,0.0833d0,0.1667d0,0d0,0d0,0d0, 0d0,

     7  0d0,  0d0,  1d0,0.3333d0,0.6667d0,0.3333d0,0d0,0d0,0d0, 0d0,

     8  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0, 0d0,

     9  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0, 0d0,

     & 0.325d0,0.325d0,0.5d0,1.6d0, 5.0d0,  0d0,  0d0,  0d0,  0d0, 0d0,

     1 0d0,0.11d0,0.16d0,0.048d0,0.50d0,0.45d0,0.55d0,0.60d0,0d0,0d0,

     2 0.2d0, 0.1d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0,  0d0, 0d0,

     3 1870*0d0/

      DATA ((vckm(i,j),j=1,4),i=1,4)/

     &  0.95113d0,  0.04884d0,  0.00003d0,  0.00000d0,

     &  0.04884d0,  0.94940d0,  0.00176d0,  0.00000d0,

     &  0.00003d0,  0.00176d0,  0.99821d0,  0.00000d0,

     &  0.00000d0,  0.00000d0,  0.00000d0,  1.00000d0/


C...PYDAT3, with particle decay parameters and data.

      DATA (mdcy(i,1),i=   1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,

     &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,

     &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,

     &2*0,6*1,0,7*1,2*0,5*1,2*0,6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,

     &1,0,4*1,163*0/

      DATA (mdcy(i,2),i=   1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80,

     &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414,

     &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0,

     &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696,

     &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923,

     &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095,

     &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124,

     &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155,

     &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248,

     &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284,

     &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343,

     &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419,

     &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519,

     &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559,

     &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584,

     &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623,

     &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731,

     &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0,

     &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489,

     &2493,2496,163*0/

      DATA (mdcy(i,3),i=   1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3,

     &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,

     &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,

     &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,

     &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,

     &4*1,4,2*0,1,2,1,2,4,1,0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,

     &1,9,2*0,8*9,0,9*9,4*1,5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,

     &9*2,11,14,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0,

     &15,0,2*4,3,2,163*0/

      DATA (mdme(i,1),i=   1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,

     &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,

     &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,

     &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,

     &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,

     &2*-1,1892*1,1503*0/

      DATA (mdme(i,2),i=   1,4000)/43*102,4*0,102,0,4*53,3*102,4*0,102,

     &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,

     &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,21*0,62*53,8*32,14*0,

     &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,

     &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,

     &15*0,4*42,5*0,3,12*0,2,3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,

     &3*0,1,11*0,22*42,41*0,2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,

     &6*0,12,2*0,12,0,12,14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,

     &3*13,2*42,9*0,14*42,19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,

     &4*32,2*4,0,32,45*0,14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,

     &2*42,2*11,0,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,

     &2*42,2*11,2*42,2*11,2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,

     &9*42,0,162*42,50*0,2*12,17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,

     &4*32,2*4,5*0,828*53,1515*0/

      DATA (brat(i)  ,i=   1, 418)/43*0d0,0.00003d0,0.00177d0,0.9982d0,

     &33*0d0,1d0,6*0d0,0.1783d0,0.1735d0,0.1131d0,0.2494d0,0.003d0,

     &0.09d0,0.0027d0,0.01d0,0.0014d0,0.0012d0,2*0.00025d0,0.0071d0,

     &0.012d0,0.0004d0,0.00075d0,0.00006d0,2*0.00078d0,0.0034d0,0.08d0,

     &0.011d0,0.0191d0,0.00006d0,0.005d0,0.0133d0,0.0067d0,0.0005d0,

     &0.0035d0,0.0006d0,0.0015d0,0.00021d0,0.0002d0,0.00075d0,0.0001d0,

     &0.0002d0,0.0011d0,3*0.0002d0,0.00022d0,0.0004d0,0.0001d0,

     &2*0.00205d0,2*0.00069d0,0.00025d0,0.00051d0,0.00025d0,35*0d0,

     &0.15403d0,0.11945d0,0.15402d0,0.11931d0,0.15215d0,3*0d0,

     &0.03357d0,0.0668d0,0.03357d0,0.0668d0,0.0335d0,0.0668d0,2*0d0,

     &0.32139d0,0.0165d0,2*0d0,0.0165d0,0.32067d0,2*0d0,0.00001d0,

     &0.00059d0,6*0d0,2*0.10814d0,0.10806d0,3*0d0,0.00031d0,0.04438d0,

     &0.88031d0,4*0d0,0.0002d0,0.05531d0,0d0,0.01838d0,0.00071d0,0d0,

     &0.00009d0,0.00032d0,62*0d0,0.14449d0,0.11223d0,0.14449d0,

     &0.11223d0,0.14443d0,0.05782d0,2*0d0,0.03172d0,0.06305d0,

     &0.03172d0,0.06305d0,0.03172d0,0.06305d0,8*0d0,0.24928d0,0.0128d0,

     &0.00001d0,0d0,0.0128d0,0.24882d0,0.00039d0,0d0,0.00001d0,

     &0.00046d0,0.22153d0,5*0d0,2*0.08464d0,0.08463d0,7*0d0,0.00005d0,

     &0.00097d0,5*0d0,0.00007d0,0d0,0.00049d0,0.00001d0,0.00006d0,

     &0.30591d0,0.68863d0,0d0,0.0038d0,66*0d0,0.00008d0,0.00167d0/

      DATA (brat(i)  ,i= 419, 722)/5*0d0,0.00013d0,0d0,0.00294d0,

     &0.00001d0,3*0d0,0.99517d0,63*0d0,0.00002d0,0.07231d0,2*0d0,

     &0.00001d0,0.00269d0,0d0,0.92497d0,18*0d0,0.0024d0,0.99483d0,

     &0.00278d0,1d0,3*0.21511d0,0.21478d0,2*0d0,2*0.06995d0,2*0d0,1d0,

     &3*0d0,0.95d0,0.05d0,3*0d0,4*0.25d0,16*0d0,4*0.25d0,20*0d0,1d0,

     &17*0d0,1d0,2*0.08d0,0.76d0,0.08d0,2*0.105d0,0.04d0,0.5d0,0.08d0,

     &0.14d0,0.01d0,0.015d0,0.005d0,0.988d0,0.012d0,0.998739d0,

     &0.00079d0,0.00038d0,0.000046d0,0.000045d0,2*0.34725d0,0.144d0,

     &0.104d0,0.0245d0,2*0.01225d0,0.0028d0,0.0057d0,0.2112d0,0.1256d0,

     &2*0.1939d0,2*0.1359d0,0.002d0,0.001d0,0.0006d0,0.999877d0,

     &0.000123d0,0.99955d0,0.00045d0,2*0.34725d0,0.144d0,0.104d0,

     &0.049d0,0.0028d0,0.0057d0,0.3923d0,0.321d0,0.2317d0,0.0478d0,

     &0.0049d0,0.0013d0,0.0003d0,0.0007d0,0.89d0,0.08693d0,0.0221d0,

     &0.00083d0,2*0.00007d0,0.564d0,0.282d0,0.072d0,0.028d0,0.023d0,

     &2*0.0115d0,0.005d0,0.003d0,0.6861d0,0.3139d0,2*0.5d0,0.665d0,

     &0.333d0,0.002d0,0.333d0,0.166d0,0.168d0,0.084d0,0.087d0,0.043d0,

     &0.059d0,2*0.029d0,0.002d0,0.6352d0,0.2116d0,0.0559d0,0.0173d0,

     &0.0482d0,0.0318d0,0.666d0,0.333d0,0.001d0,0.332d0,0.166d0,

     &0.168d0,0.084d0,0.086d0,0.043d0,0.059d0,2*0.029d0,2*0.002d0,

     &0.437d0,0.208d0,0.302d0,0.0302d0,0.0212d0,0.0016d0,0.48947d0/

      DATA (brat(i)  ,i= 723, 897)/0.34d0,3*0.043d0,0.027d0,0.0126d0,

     &0.0013d0,0.0003d0,0.00025d0,0.00008d0,0.444d0,2*0.222d0,0.104d0,

     &2*0.004d0,0.07d0,0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.07d0,

     &0.065d0,2*0.005d0,2*0.011d0,5*0.001d0,0.026d0,0.019d0,0.066d0,

     &0.041d0,0.045d0,0.076d0,0.0073d0,2*0.0047d0,0.026d0,0.001d0,

     &0.0006d0,0.0066d0,0.005d0,2*0.003d0,2*0.0006d0,2*0.001d0,0.006d0,

     &0.005d0,0.012d0,0.0057d0,0.067d0,0.008d0,0.0022d0,0.027d0,

     &0.004d0,0.019d0,0.012d0,0.002d0,0.009d0,0.0218d0,0.001d0,0.022d0,

     &0.087d0,0.001d0,0.0019d0,0.0015d0,0.0028d0,0.683d0,0.306d0,

     &0.011d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,

     &0.034d0,0.027d0,2*0.002d0,2*0.004d0,2*0.002d0,0.034d0,0.027d0,

     &2*0.002d0,2*0.004d0,2*0.002d0,0.0365d0,0.045d0,0.073d0,0.062d0,

     &3*0.021d0,0.0061d0,0.015d0,0.025d0,0.0088d0,0.074d0,0.0109d0,

     &0.0041d0,0.002d0,0.0035d0,0.0011d0,0.001d0,0.0027d0,2*0.0016d0,

     &0.0018d0,0.011d0,0.0063d0,0.0052d0,0.018d0,0.016d0,0.0034d0,

     &0.0036d0,0.0009d0,0.0006d0,0.015d0,0.0923d0,0.018d0,0.022d0,

     &0.0077d0,0.009d0,0.0075d0,0.024d0,0.0085d0,0.067d0,0.0511d0,

     &0.017d0,0.0004d0,0.0028d0,0.619d0,0.381d0,0.3d0,0.15d0,0.16d0,

     &0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.01d0,2*0.02d0,0.03d0,

     &2*0.005d0,2*0.02d0,0.03d0,2*0.005d0,0.015d0,0.037d0,0.028d0/

      DATA (brat(i)  ,i= 898,1063)/0.079d0,0.095d0,0.052d0,0.0078d0,

     &4*0.001d0,0.028d0,0.033d0,0.026d0,0.05d0,0.01d0,4*0.005d0,0.25d0,

     &0.0952d0,0.94d0,0.06d0,2*0.4d0,2*0.1d0,1d0,0.0602d0,0.0601d0,

     &0.8797d0,0.135d0,0.865d0,0.02d0,0.055d0,2*0.005d0,0.008d0,

     &0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,

     &0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,

     &0.0185d0,0.0135d0,0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,

     &0.0019d0,0.0025d0,0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,

     &1d0,0.3d0,0.15d0,0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,

     &0.02d0,0.055d0,2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,

     &2*0.005d0,0.008d0,0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,

     &0.0055d0,0.0042d0,0.009d0,0.018d0,0.015d0,0.0185d0,0.0135d0,

     &0.025d0,0.0004d0,0.0007d0,0.0008d0,0.0014d0,0.0019d0,0.0025d0,

     &0.4291d0,0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,1d0,0.3d0,0.15d0,

     &0.16d0,0.08d0,0.13d0,0.06d0,0.08d0,0.04d0,0.02d0,0.055d0,

     &2*0.005d0,0.008d0,0.012d0,0.02d0,0.055d0,2*0.005d0,0.008d0,

     &0.012d0,0.01d0,0.03d0,0.0035d0,0.011d0,0.0055d0,0.0042d0,0.009d0,

     &0.018d0,0.015d0,0.0185d0,0.0135d0,0.025d0,2*0.0002d0,0.0007d0,

     &2*0.0004d0,0.0014d0,0.001d0,0.0009d0,0.0025d0,0.4291d0,0.08d0,

     &0.07d0,0.02d0,0.015d0,0.005d0,1d0,2*0.3d0,2*0.2d0,0.047d0/

      DATA (brat(i)  ,i=1064,1254)/0.122d0,0.006d0,0.012d0,0.035d0,

     &0.012d0,0.035d0,0.003d0,0.007d0,0.15d0,0.037d0,0.008d0,0.002d0,

     &0.05d0,0.015d0,0.003d0,0.001d0,0.014d0,0.042d0,0.014d0,0.042d0,

     &0.24d0,0.065d0,0.012d0,0.003d0,0.001d0,0.002d0,0.001d0,0.002d0,

     &0.014d0,0.003d0,1d0,2*0.3d0,2*0.2d0,1d0,0.0252d0,0.0248d0,

     &0.0267d0,0.015d0,0.045d0,0.015d0,0.045d0,0.7743d0,0.029d0,0.22d0,

     &0.78d0,1d0,0.331d0,0.663d0,0.006d0,0.663d0,0.331d0,0.006d0,1d0,

     &0.999d0,0.001d0,0.88d0,2*0.06d0,0.639d0,0.358d0,0.002d0,0.001d0,

     &1d0,0.88d0,2*0.06d0,0.516d0,0.483d0,0.001d0,0.88d0,2*0.06d0,

     &0.9988d0,0.0001d0,0.0006d0,0.0004d0,0.0001d0,0.667d0,0.333d0,

     &0.9954d0,0.0011d0,0.0035d0,0.333d0,0.667d0,0.676d0,0.234d0,

     &0.085d0,0.005d0,2*1d0,0.018d0,2*0.005d0,0.003d0,0.002d0,

     &2*0.006d0,0.018d0,2*0.005d0,0.003d0,0.002d0,2*0.006d0,0.0066d0,

     &0.025d0,0.016d0,0.0088d0,2*0.005d0,0.0058d0,0.005d0,0.0055d0,

     &4*0.004d0,2*0.002d0,2*0.004d0,0.003d0,0.002d0,2*0.003d0,

     &3*0.002d0,2*0.001d0,0.002d0,2*0.001d0,2*0.002d0,0.0013d0,

     &0.0018d0,5*0.001d0,4*0.003d0,2*0.005d0,2*0.002d0,2*0.001d0,

     &2*0.002d0,2*0.001d0,0.2432d0,0.057d0,2*0.035d0,0.15d0,2*0.075d0,

     &0.03d0,2*0.015d0,2*0.08d0,0.76d0,0.08d0,4*1d0,2*0.08d0,0.76d0,

     &0.08d0,1d0,2*0.5d0,1d0,2*0.5d0,2*0.08d0,0.76d0,0.08d0,1d0/

      DATA (brat(i)  ,i=1255,1447)/2*0.08d0,0.76d0,3*0.08d0,0.76d0,

     &3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,3*0.08d0,0.76d0,

     &3*0.08d0,0.76d0,0.08d0,2*1d0,2*0.105d0,0.04d0,0.0077d0,0.02d0,

     &0.0235d0,0.0285d0,0.0435d0,0.0011d0,0.0022d0,0.0044d0,0.4291d0,

     &0.08d0,0.07d0,0.02d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,

     &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,

     &0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,0.04d0,

     &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,0.04d0,

     &0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,4*1d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,1d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0,

     &0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,0.015d0,0.005d0,2*0.105d0/

      DATA (brat(i)  ,i=1448,1648)/0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,2*0.105d0,0.04d0,0.5d0,0.08d0,0.14d0,0.01d0,

     &0.015d0,0.005d0,4*1d0,0.52d0,0.26d0,0.11d0,2*0.055d0,0.333d0,

     &0.334d0,0.333d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,

     &0.11d0,0.667d0,0.333d0,0.28d0,0.14d0,0.313d0,0.157d0,0.11d0,

     &0.36d0,0.18d0,0.03d0,2*0.015d0,2*0.2d0,4*0.25d0,0.667d0,0.333d0,

     &0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.007d0,

     &0.993d0,1d0,0.667d0,0.333d0,0.667d0,0.333d0,0.667d0,0.333d0,

     &0.667d0,0.333d0,8*0.5d0,0.02d0,0.98d0,1d0,4*0.5d0,3*0.146d0,

     &3*0.05d0,0.15d0,2*0.05d0,4*0.024d0,0.066d0,0.667d0,0.333d0,

     &0.667d0,0.333d0,4*0.25d0,0.667d0,0.333d0,0.667d0,0.333d0,2*0.5d0,

     &0.273d0,0.727d0,0.667d0,0.333d0,0.667d0,0.333d0,4*0.5d0,0.35d0,

     &0.65d0,2*0.0083d0,0.1866d0,0.324d0,0.184d0,0.027d0,0.001d0,

     &0.093d0,0.087d0,0.078d0,0.0028d0,3*0.014d0,0.008d0,0.024d0/

      DATA (brat(i)  ,i=1649,4000)/0.008d0,0.024d0,0.425d0,0.02d0,

     &0.185d0,0.088d0,0.043d0,0.067d0,0.066d0,827*0d0,0.8516d0,

     &0.00539d0,0.04483d0,0.09819d0,0.85053d0,0.02152d0,0.02989d0,

     &0.09806d0,0.29439d0,0.10943d0,0.59618d0,0.38983d0,0.61017d0,

     &1503*0d0/

      DATA (kfdp(i,1),i=   1, 375)/21,22,23,4*-24,25,21,22,23,4*24,25,

     &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,

     &4*24,25,37,1000022,1000023,1000025,1000035,21,22,23,4*-24,25,

     &2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,22,23,-24,25,

     &23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,-37,23,24,37,

     &1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,3,4,5,6,7,8,

     &11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,1,2,

     &3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,2*1000023,

     &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,

     &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003,

     &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,

     &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,

     &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,

     &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,

     &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,

     &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,

     &24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,3*24,1,2,3,

     &4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,1000022,2*1000023,

     &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,

     &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/

      DATA (kfdp(i,1),i= 376, 606)/1000003,-1000003,1000004,2000004,

     &1000004,-1000004,1000005,2000005,1000005,-1000005,1000006,

     &2000006,1000006,-1000006,1000011,2000011,1000011,-1000011,

     &1000012,2000012,1000012,-1000012,1000013,2000013,1000013,

     &-1000013,1000014,2000014,1000014,-1000014,1000015,2000015,

     &1000015,-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,

     &8,11,13,15,17,21,2*22,23,24,23,1000022,2*1000023,3*1000025,

     &4*1000035,2*1000024,2*1000037,1000001,2000001,1000001,-1000001,

     &1000002,2000002,1000002,-1000002,1000003,2000003,1000003,

     &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,

     &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,

     &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,

     &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,

     &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,

     &1000016,-1000016,-1,-3,-5,-7,-11,-13,-15,-17,24,2*1000022,

     &2*1000023,2*1000025,2*1000035,1000006,2000006,1000006,2000006,

     &-1000001,-1000003,-1000011,-1000013,-1000015,-2000015,5,6,21,2,1,

     &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,

     &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,

     &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/

      DATA (kfdp(i,1),i= 607,1001)/-11,-13,2*2,-12,-14,-16,2*-2,2*-4,

     &-2,-4,2*22,211,111,221,13,11,213,-213,221,223,321,130,310,111,

     &331,111,211,-12,12,-14,14,211,111,22,-13,-11,2*211,213,113,221,

     &223,321,211,331,22,111,211,2*22,211,22,111,211,22,211,221,111,11,

     &211,111,2*211,321,130,310,221,111,211,111,130,310,321,2*311,321,

     &311,323,313,323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,

     &313,323,313,323,311,4*321,211,111,3*22,111,321,130,-213,113,213,

     &211,22,111,11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,

     &-313,-311,-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,

     &2*113,2*223,2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,

     &-321,211,2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,

     &423,413,421,411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,

     &-313,2*-311,-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,

     &3*-321,-311,-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,

     &-321,3*-311,211,113,321,2*421,411,421,413,423,413,423,411,421,

     &-15,5*-11,5*-13,221,331,333,221,331,333,10221,211,213,211,213,

     &321,323,321,323,2212,221,331,333,221,2*2,2*431,421,411,423,413,

     &82,11,13,82,443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,

     &2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,

     &511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443/

      DATA (kfdp(i,1),i=1002,1428)/2*20443,2*2,2*4,2,4,521,511,521,513,

     &523,513,523,511,521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,

     &3*441,3*443,3*20443,2*2,2*4,2,4,531,521,511,523,513,16,2*4,2*12,

     &2*14,2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,

     &521,513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,

     &2212,2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,

     &3222,3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,

     &3322,3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,

     &7*-13,2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,

     &2*3322,3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,

     &2*3214,2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,

     &2*2,3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,

     &-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,

     &-12,-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,

     &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,

     &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,

     &-14,-16,2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,

     &-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,

     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,

     &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12/

      DATA (kfdp(i,1),i=1429,1710)/-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,

     &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,

     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,

     &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,

     &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,

     &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,

     &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,

     &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,

     &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,

     &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,

     &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,

     &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,

     &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,

     &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,

     &1000002,2000002,1000002,2000002,1000021,1000039,1000024,1000037,

     &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001,

     &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,

     &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024,

     &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003,

     &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/

      DATA (kfdp(i,1),i=1711,1900)/1000025,1000035,1000006,2000006,

     &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023,

     &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,

     &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,

     &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022,

     &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039,

     &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014,

     &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023,

     &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024,

     &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016,

     &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035,

     &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001,

     &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,

     &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,

     &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,

     &6*1000022,6*1000023,6*1000025,6*1000035,1000024,-1000024,1000024,

     &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,

     &1000037,-1000037,10*1000039,16*1000022,1000024,-1000024,1000024,

     &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,

     &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/

      DATA (kfdp(i,1),i=1901,2095)/-1000037,1000037,-1000037,1000037,

     &-1000037,1000037,-1000037,1000024,-1000024,1000037,-1000037,

     &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,

     &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,

     &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,

     &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,

     &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,

     &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,

     &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,

     &2*1000039,6*1000022,6*1000023,6*1000025,6*1000035,1000022,

     &1000023,1000025,1000035,1000002,2000002,-1000001,-2000001,

     &1000004,2000004,-1000003,-2000003,1000006,2000006,-1000005,

     &-2000005,1000012,2000012,-1000011,-2000011,1000014,2000014,

     &-1000013,-2000013,1000016,2000016,-1000015,-2000015,2*1000021,

     &5*1000039,16*1000022,16*1000023,1000024,-1000024,1000024,

     &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,

     &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,

     &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,

     &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,

     &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/

      DATA (kfdp(i,1),i=2096,2323)/2000003,-2000003,1000004,-1000004,

     &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,

     &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,

     &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,

     &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,

     &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,

     &5*1000039,16*1000022,16*1000023,16*1000025,1000024,-1000024,

     &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,

     &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,

     &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,

     &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001,

     &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003,

     &-1000003,2000003,-2000003,1000004,-1000004,2000004,-2000004,

     &1000005,-1000005,2000005,-2000005,1000006,-1000006,2000006,

     &-2000006,1000011,-1000011,2000011,-2000011,1000012,-1000012,

     &2000012,-2000012,1000013,-1000013,2000013,-2000013,1000014,

     &-1000014,2000014,-2000014,1000015,-1000015,2000015,-2000015,

     &1000016,-1000016,2000016,-2000016,5*1000021,2*1000039,15*1000024,

     &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,

     &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/

      DATA (kfdp(i,1),i=2324,4000)/-1000003,-2000003,1000006,2000006,

     &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014,

     &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,

     &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025,

     &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021,

     &1000039,1000024,1000037,1000022,1000023,1000025,1000035,

     &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039,

     &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,

     &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037,

     &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003,

     &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022,

     &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006,

     &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,

     &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021,

     &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,

     &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024,

     &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014,

     &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022,

     &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016,

     &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/

      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,

     &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,

     &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,

     &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,

     &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,

     &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,

     &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,

     &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,

     &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,

     &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,

     &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,

     &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,

     &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,

     &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,

     &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,

     &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,

     &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,

     &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,

     &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,

     &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/

      DATA (kfdp(i,2),i= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23,

     &-24,2*25,36,2*1000022,1000023,1000022,1000023,1000025,1000022,

     &1000023,1000025,1000035,-1000024,-1000037,-1000024,-1000037,

     &-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,

     &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,

     &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,

     &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,

     &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,

     &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,

     &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,25,2*1000022,1000023,

     &1000022,1000023,1000025,1000022,1000023,1000025,1000035,-1000024,

     &-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,-1000002,

     &2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,

     &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,

     &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,

     &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,

     &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,

     &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,

     &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,

     &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-5,-6,21,11/

      DATA (kfdp(i,2),i= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5,

     &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7,

     &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2,

     &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,

     &-13,-14,-15,-16,-17,-18,-82,12,14,-1,-3,11,13,15,1,4,3,4,1,3,22,

     &11,-211,2*22,-13,-11,-211,211,111,211,-321,130,310,22,2*111,-211,

     &11,-11,13,-13,-211,111,22,14,12,111,22,111,3*211,-311,22,211,22,

     &111,-211,211,11,-211,13,22,-211,111,-211,22,111,-11,-211,111,

     &2*-211,-321,130,310,221,111,-211,111,2*0,-211,111,22,-211,111,

     &-211,111,-211,211,-213,113,223,221,14,111,211,111,-11,-13,211,

     &111,22,211,111,211,111,2*211,213,113,223,221,22,-211,111,113,223,

     &22,111,-321,310,211,111,2*-211,221,22,-11,-13,-211,-321,130,310,

     &221,-211,111,11*12,11*14,2*211,2*213,211,20213,2*321,2*323,211,

     &213,211,213,211,213,211,213,211,213,211,213,3*211,213,211,2*321,

     &8*211,2*113,3*211,111,22,211,111,211,111,4*211,8*12,8*14,2*211,

     &2*213,2*111,221,2*113,223,333,20213,211,2*321,323,2*311,313,-211,

     &111,113,2*211,321,2*211,311,321,310,211,-211,4*211,321,4*211,113,

     &2*211,-321,111,22,-211,111,-211,111,-211,211,-211,211,16,5*12,

     &5*14,3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,

     &2*-1,22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13/

      DATA (kfdp(i,2),i= 941,1318)/2*-15,211,213,20213,211,213,20213,

     &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,

     &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,

     &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1,

     &-4,-3,-4,-1,-3,22,211,111,211,111,4*211,6*-11,6*-13,2*-15,211,

     &213,20213,211,213,20213,431,433,431,433,221,331,333,221,331,333,

     &221,331,333,-1,-4,-3,-4,-1,-3,22,-321,-311,-321,-311,-15,-3,-1,

     &2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,-4,-1,-4,2*12,2*14,2,3,2,3,2*12,

     &2*14,2,1,22,411,421,411,421,21,-11,-13,-15,-1,-2,-3,-4,2*21,22,

     &21,2*-211,111,22,111,211,22,211,-211,11,2*-211,111,-211,111,22,

     &11,22,111,-211,211,111,211,22,211,111,211,-211,22,11,13,11,-211,

     &2*111,2*22,111,211,-321,-211,111,11,2*-211,7*12,7*14,-321,-323,

     &-311,-313,-311,-313,211,213,211,213,211,213,111,221,331,113,223,

     &111,221,113,223,321,323,321,-211,-213,111,221,331,113,223,333,

     &10221,111,221,331,113,223,211,213,211,213,321,323,321,323,321,

     &323,311,313,311,313,2*-1,-3,-1,2203,3201,3203,2203,2101,2103,12,

     &14,-1,-3,2*111,2*211,12,14,-1,-3,22,111,2*22,111,22,12,14,-1,-3,

     &22,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,

     &12,14,-1,-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,

     &-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1/

      DATA (kfdp(i,2),i=1319,1774)/3,2*111,2*211,11,13,15,1,4,3,4,1,3,

     &11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,

     &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,

     &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,

     &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,

     &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,

     &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,

     &11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,-211,111,

     &-321,130,310,-211,111,211,-211,111,-213,113,-211,111,223,211,111,

     &213,113,211,111,223,-211,111,-321,130,310,2*-211,-311,311,-321,

     &321,211,111,211,111,-211,111,-211,111,311,2*321,311,22,2*-82,

     &-211,111,-211,111,211,111,211,111,-321,-311,-321,-311,411,421,

     &411,421,22,2*21,-211,2*211,111,-211,111,2*211,111,-211,211,111,

     &211,-321,2*-311,-321,22,-211,111,211,111,-311,311,-321,321,211,

     &111,-211,111,321,311,22,-82,-211,111,211,111,-321,-311,411,421,

     &22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,-15,-1,-2,-3,-4,

     &2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,1,2,2*1,4*2,2*24,2*37,2,

     &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,

     &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,

     &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/

      DATA (kfdp(i,2),i=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15,

     &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,

     &-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,

     &-1,3,-3,5,-5,1,-1,3,-3,5,-5,22,23,25,35,36,22,23,25,35,36,22,23,

     &11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,

     &1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,

     &1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,

     &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,

     &-16,16,-16,16,1,3,5,2,4,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,

     &-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,

     &2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,22,

     &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,

     &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,

     &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,

     &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,

     &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,

     &-16,16,-16,16,1,3,5,2,4,22,23,25,35,36,22,23,11,13,15,12,14,16,1,

     &3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,

     &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,

     &-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37/

      DATA (kfdp(i,2),i=2219,4000)/37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,

     &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,

     &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,24,37,

     &23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,-13,-15,-1,-3,24,

     &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,

     &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,

     &-3,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36,

     &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,

     &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,

     &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13,

     &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24,

     &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/

      DATA (kfdp(i,3),i=   1,1087)/79*0,14,6*0,2*16,2*0,6*111,310,130,

     &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,

     &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,

     &470*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,

     &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,

     &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,

     &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,

     &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,

     &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,

     &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,

     &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,

     &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,

     &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,

     &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,

     &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,

     &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,

     &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,

     &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,

     &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,

     &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/

      DATA (kfdp(i,3),i=1088,2186)/511,513,511,513,1,2,13*0,2*21,11*0,

     &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,

     &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,

     &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,

     &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,

     &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,

     &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,

     &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,

     &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,

     &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,

     &-211,111,13*0,2*21,-211,111,167*0,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,

     &-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,6,-2,2,-4,

     &4,-6,6,12*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,

     &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,

     &-1,-3,-5,-2,-4,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,

     &12,14,16,2,4,28*0,2,4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,

     &5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,

     &16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,

     &-4,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,

     &-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5/

      DATA (kfdp(i,3),i=2187,4000)/-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,

     &-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,3*0,

     &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,4*0,12,14,16,2,4,0,12,14,

     &16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,1657*0/

      DATA (kfdp(i,4),i=   1,4000)/92*0,4*111,6*0,111,2*0,-211,0,-211,

     &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,

     &6*111,310,2*130,470*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,

     &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,

     &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,

     &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,

     &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,

     &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,

     &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,

     &162*81,31*0,-211,111,2450*0/

      DATA (kfdp(i,5),i=   1,4000)/94*0,2*111,17*0,111,7*0,2*111,0,

     &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211,

     &3*111,-211,111,3127*0/


C...PYDAT4, with particle names (character strings).

      DATA (chaf(i,1),i=   1, 190)/'d','u','s','c','b','t','b''','t''',

     &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',

     &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',2*' ','reggeon',

     &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0',

     &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0',

     &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav',

     &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster',

     &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet',

     &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0',

     &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2',

     &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''',

     &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+',

     &'D*_s+','D*_2s+','J/psi_di','eta_c','J/psi','chi_2c','B0','B*0',

     &'B*_20','B+','B*+','B*_2+','B_s0','B*_s0','B*_2s0','B_c+',

     &'B*_c+','B*_2c+','eta_b','Upsilon','chi_2b','dd_1','Delta-',

     &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','p+',

     &'Delta+','Delta++','sd_0','sd_1','Sigma-','Sigma*-','Lambda0',

     &'su_0','su_1','Sigma0','Sigma*0','Sigma+','Sigma*+','ss_1','Xi-',

     &'Xi*-','Xi0','Xi*0','Omega-','cd_0','cd_1','Sigma_c0',

     &'Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1','Sigma_c+'/

      DATA (chaf(i,1),i= 191, 317)/'Sigma*_c+','Sigma_c++',

     &'Sigma*_c++','Xi_c+','cs_0','cs_1','Xi''_c0','Xi*_c0','Xi''_c+',

     &'Xi*_c+','Omega_c0','Omega*_c0','cc_1','Xi_cc+','Xi*_cc+',

     &'Xi_cc++','Xi*_cc++','Omega_cc+','Omega*_cc+','Omega*_ccc++',

     &'bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0','Xi_b-',

     &'Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',

     &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',

     &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',

     &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',

     &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',

     &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',

     &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',

     &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',

     &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',

     &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',

     &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',

     &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',

     &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',

     &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',

     &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+'/

      DATA (chaf(i,1),i= 318, 500)/'~chi_30','~chi_40','~chi_2+',

     &'~gravitino','~d_R','~u_R','~s_R','~c_R','~b_2','~t_2','~e_R-',

     &'~nu_eR','~mu_R-','~nu_muR','~tau_2-','~nu_tauR','d*','u*','e*-',

     &'nu*_e0',163*' '/

      DATA (chaf(i,2),i=   1, 206)/'dbar','ubar','sbar','cbar','bbar',

     &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',

     &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',

     &'W''-',2*' ','H-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ',

     &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar',

     &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0',

     &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0',

     &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0',

     &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0',

     &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+',

     &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar',

     &'p_diffrbar-','pbar-','Deltabar-','Deltabar--','sd_0bar',

     &'sd_1bar','Sigmabar+','Sigma*bar+','Lambdabar0','su_0bar',

     &'su_1bar','Sigmabar0','Sigma*bar0','Sigmabar-','Sigma*bar-',

     &'ss_1bar','Xibar+','Xi*bar+','Xibar0','Xi*bar0','Omegabar+',

     &'cd_0bar','cd_1bar','Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-',

     &'Xi_cbar0','cu_0bar','cu_1bar','Sigma_cbar-','Sigma*_cbar-',

     &'Sigma_cbar--','Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar',

     &'Xi''_cbar0','Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',

     &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--'/

      DATA (chaf(i,2),i= 207, 324)/'Xi*_ccbar--','Omega_ccbar-',

     &'Omega*_ccbar-','Omega*_cccbar-','bd_0bar','bd_1bar',

     &'Sigma_bbar+','Sigma*_bbar+','Lambda_bbar0','Xi_bbar+',

     &'Xi_bcbar0','bu_0bar','bu_1bar','Sigma_bbar0','Sigma*_bbar0',

     &'Sigma_bbar-','Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar',

     &'bs_1bar','Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0',

     &'Omega_bbar+','Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar',

     &'Xi''_bcbar0','Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-',

     &'Omega''_bcba','Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-',

     &'bb_1bar','Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0',

     &'Omega_bbbar+','Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',

     &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',

     &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',

     &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',

     &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',

     &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',

     &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',

     &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',

     &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',

     &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar'/

      DATA (chaf(i,2),i= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar',

     &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+',

     &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/


C...PYDATR, with initial values for the random number generator.

      DATA mrpy/19780503,0,0,97,33,0/


C...Default values for allowed processes and kinematics constraints.

      DATA msel/1/

      DATA msub/500*0/

      DATA ((kfin(i,j),j=-40,40),i=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,

     &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,

     &6*1,4*0,4*1,16*0/

      DATA ckin/

     &  2.0d0, -1.0d0,  0.0d0, -1.0d0,  1.0d0,

     &  1.0d0,  -10d0,   10d0,  -10d0,   10d0,

     1  -10d0,   10d0,  -10d0,   10d0,  -10d0,

     1   10d0, -1.0d0,  1.0d0, -1.0d0,  1.0d0,

     2  0.0d0,  1.0d0,  0.0d0,  1.0d0, -1.0d0,

     2  1.0d0, -1.0d0,  1.0d0,    0d0,    0d0,

     3  2.0d0, -1.0d0,    0d0,    0d0,  0.0d0,

     3 -1.0d0,  0.0d0, -1.0d0,  4.0d0, -1.0d0,

     4 12.0d0, -1.0d0, 12.0d0, -1.0d0, 12.0d0,

     4 -1.0d0, 12.0d0, -1.0d0,    0d0,    0d0,

     5  0.0d0, -1.0d0,  0.0d0, -1.0d0,  0.0d0,

     5 -1.0d0,    0d0,    0d0,    0d0,    0d0,

     6  140*0d0/


C...Default values for main switches and parameters. Reset information.

      DATA (mstp(i),i=1,100)/

     &  3,    1,    2,    0,    0,    0,    0,    0,    0,    0,

     1  1,    0,    1,    0,    5,    0,    0,    0,    0,    0,

     2  1,    0,    1,    0,    0,    0,    0,    0,    0,    1,

     3  1,    2,    0,    1,    0,    2,    1,    5,    2,    0,

     4  1,    1,    3,    7,    3,    1,    1,    2,    1,    0,

     5  4,    1,    3,    1,    5,    1,    1,    6,    1,    7,

     6  1,    3,    2,    2,    1,    1,    2,    0,    0,    0,

     7  1,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     8  1,    1,  100,    0,    0,    0,    0,    0,    0,    0,

     9  1,    4,    1,    2,    0,    0,    0,    0,    0,    0/

      DATA (mstp(i),i=101,200)/

     &  3,    1,    0,    0,    0,    0,    0,    0,    0,    0,

     1  1,    1,    1,    0,    0,    0,    0,    0,    0,    0,

     2  0,    1,    2,    1,    1,   50,    0,    0,   10,    0,

     3  0,    4,    0,    1,    0,    0,    0,    0,    0,    0,

     4  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     5  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     6  0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     7  0,    2,    0,    0,    0,    0,    0,    0,    0,    0,

     8  6,  102, 1997,   04,   22,    0,    0,    0,    0,    0,

     9  0,    0,    0,    0,    0,    0,    0,    0,    0,    0/

      DATA (parp(i),i=1,100)/

     &  0.25d0,  10d0, 8*0d0,

     1  0d0,   0d0,  1.0d0, 0.01d0,  0.6d0,  1.0d0,  1.0d0, 3*0d0,

     2  10*0d0,

     3  1.5d0,2.0d0,0.075d0,1.0d0,0.2d0,0d0,2.0d0,0.70d0,0.006d0,0d0,

     4  0.02d0,2.0d0,0.10d0,1000d0,2054d0, 123d0, 246d0, 50d0, 2*0d0,

     5  1.0d0, 9*0d0,

     6  0.25d0, 1.0d0,0.25d0, 1.0d0, 2.0d0,1d-3, 4.0d0,1d-3,2*0d0,

     7  4.0d0, 0.25d0, 8*0d0,

     8  1.40d0,1.55d0,0.5d0, 0.2d0,0.33d0,0.66d0, 0.7d0, 0.5d0,2*0d0,

     9  0.44d0,0.20d0,2.0d0,1.0d0,0d0,3.0d0,1.0d0,0.75d0,0.44d0,2.0d0/

      DATA (parp(i),i=101,200)/

     &  0.5d0, 0.28d0,  1.0d0, 0.8d0, 6*0d0,

     1  2.0d0, 3*0d0, 1.5d0, 0.5d0, 0.6d0, 2.5d0, 2.0d0, 1.0d0,

     2  1.0d0,  0.4d0, 8*0d0,

     3  0.01d0, 9*0d0,

     4  0.33333d0, 82d0, 1d0, 4d0, 200d0, 5*0d0,

     5  0d0,   0d0,   0d0,   0d0, 6*0d0,

     6  2.20d0, 23.6d0, 18.4d0, 11.5d0, 6*0d0,

     7  0d0,   0d0,   0d0,  1.0d0, 6*0d0,

     8  20*0d0/

      DATA msti/200*0/

      DATA pari/200*0d0/

      DATA mint/400*0/

      DATA vint/400*0d0/


C...Constants for the generation of the various processes.

      DATA (iset(i),i=1,100)/

     &  1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,    2,

     1  2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,

     2 -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,

     3  2,   -1,    2,    2,    2,    2,   -1,   -1,   -1,   -1,

     4 -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,

     5 -1,   -1,    2,    2,   -1,   -1,   -1,    2,   -1,   -1,

     6 -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,    2,    2,

     7  4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,    2,

     8  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,

     9  0,    0,    0,    0,    0,    9,   -2,   -2,   -2,   -2/

      DATA (iset(i),i=101,200)/

     & -1,    1,    1,   -2,   -2,   -2,   -2,   -2,   -2,    2,

     1  2,    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,

     2  5,    5,    5,    5,   -2,   -2,   -2,   -2,   -2,   -2,

     3 -1,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,

     4  1,    1,    1,    1,    1,   -2,    1,    1,    1,   -2,

     5  1,    1,    1,   -2,   -2,    1,    1,    1,   -2,   -2,

     6  2,    2,    2,    2,    2,    2,    2,    2,   -2,   -2,

     7  2,    2,    5,    5,   -2,    2,    2,    5,    5,   -2,

     8  5,    5,   -2,   -2,   -2,    5,    5,   -2,   -2,   -2,

     9  1,    1,    1,    2,   -2,   -2,   -2,   -2,   -2,   -2/

      DATA (iset(i),i=201,300)/

     &  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,

     1  2,    2,    2,    2,   -2,    2,    2,    2,    2,    2,

     2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,

     3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,

     4  2,    2,    2,    2,   -1,    2,    2,    2,    2,    2,

     5  2,    2,    2,    2,   -1,    2,   -1,    2,    2,   -2,

     6  2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,   -1,

     7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,

     8 -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,

     9 -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2,   -2/

      DATA (iset(i),i=301,500)/200*-2/

      DATA ((kfpr(i,j),j=1,2),i=1,50)/

     &  23,    0,   24,    0,   25,    0,   24,    0,   25,    0,

     &  24,    0,   23,    0,   25,    0,    0,    0,    0,    0,

     1   0,    0,    0,    0,   21,   21,   21,   22,   21,   23,

     1  21,   24,   21,   25,   22,   22,   22,   23,   22,   24,

     2  22,   25,   23,   23,   23,   24,   23,   25,   24,   24,

     2  24,   25,   25,   25,    0,   21,    0,   22,    0,   23,

     3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,

     3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,

     4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,

     4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23/

      DATA ((kfpr(i,j),j=1,2),i=51,100)/

     5   0,   24,    0,   25,    0,    0,    0,    0,    0,    0,

     5   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     6   0,    0,    0,    0,   21,   21,   24,   24,   23,   24,

     7  23,   23,   24,   24,   23,   24,   23,   25,   22,   22,

     7  23,   23,   24,   24,   24,   25,   25,   25,    0,  211,

     8   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     8 443,   21,10441,   21,20443,   21,  445,   21,    0,    0,

     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/

      DATA ((kfpr(i,j),j=1,2),i=101,150)/

     &  23,    0,   25,    0,   25,    0,    0,    0,    0,    0,

     &   0,    0,    0,    0,    0,    0,    0,    0,   22,   25,

     1  21,   25,    0,   25,   21,   25,   22,   22,   21,   22,

     1  22,   23,   23,   23,   24,   24,    0,    0,    0,    0,

     2  25,    6,   25,    6,   25,    0,   25,    0,    0,    0,

     2   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     3  23,    5,    0,    0,    0,    0,    0,    0,    0,    0,

     3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,

     4  32,    0,   34,    0,   37,    0,   40,    0,   39,    0,

     4   0,    0, 4000001, 0, 4000002, 0,   38,    0,    0,    0/

      DATA ((kfpr(i,j),j=1,2),i=151,200)/

     5  35,    0,   35,    0,   35,    0,    0,    0,    0,    0,

     5  36,    0,   36,    0,   36,    0,    0,    0,    0,    0,

     6   6,   37,   39,    0,   39,   39,   39,   39,   11,    0,

     6  11,    0, 0, 4000001, 0, 4000002,    0,    0,    0,    0,

     7  23,   35,   24,   35,   35,    0,   35,    0,    0,    0,

     7  23,   36,   24,   36,   36,    0,   36,    0,    0,    0,

     8  35,    6,   35,    6,    0,    0,    0,    0,    0,    0,

     8  36,    6,   36,    6,    0,    0,    0,    0,    0,    0,

     9  54,    0,   55,    0,   56,    0,   11,    0,    0,    0,

     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/

      DATA ((kfpr(i,j),j=1,2),i=201,240)/

     &  1000011,   1000011,   2000011,   2000011,   1000011,

     &  2000011,   1000013,   1000013,   2000013,   2000013,

     &  1000013,   2000013,   1000015,   1000015,   2000015,

     &  2000015,   1000015,   2000015,   1000011,   1000012,

     1  1000015,   1000016,   2000015,   1000016,   1000012,

     1  1000012,   1000016,   1000016,         0,         0,

     1  1000022,   1000022,   1000023,   1000023,   1000025,

     1  1000025,   1000035,   1000035,   1000022,   1000023,

     2  1000022,   1000025,   1000022,   1000035,   1000023,

     2  1000025,   1000023,   1000035,   1000025,   1000035,

     2  1000024,   1000024,   1000037,   1000037,   1000024,

     2  1000037,   1000022,   1000024,   1000023,   1000024,

     3  1000025,   1000024,   1000035,   1000024,   1000022,

     3  1000037,   1000023,   1000037,   1000025,   1000037,

     3  1000035,   1000037,   1000021,   1000022,   1000021,

     3  1000023,   1000021,   1000025,   1000021,   1000035/

      DATA ((kfpr(i,j),j=1,2),i=241,280)/

     4  1000021,   1000024,   1000021,   1000037,   1000021,

     4  1000021,   1000021,   1000021,         0,         0,

     4  1000002,   1000022,   2000002,   1000022,   1000002,

     4  1000023,   2000002,   1000023,   1000002,   1000025,

     5  2000002,   1000025,   1000002,   1000035,   2000002,

     5  1000035,   1000001,   1000024,   2000005,   1000024,

     5  1000001,   1000037,   2000005,   1000037,   1000002,

     5  1000021,   2000002,   1000021,         0,         0,

     6  1000006,   1000006,   2000006,   2000006,   1000006,

     6  2000006,   1000006,   1000006,   2000006,   2000006,

     6        0,         0,         0,         0,         0,

     6        0,         0,         0,         0,         0,

     7  1000002,   1000002,   2000002,   2000002,   1000002,

     7  2000002,   1000002,   1000002,   2000002,   2000002,

     7  1000002,   2000002,   1000002,   1000002,   2000002,

     7  2000002,   1000002,   1000002,   2000002,   2000002/

      DATA ((kfpr(i,j),j=1,2),i=281,500)/440*0/

      DATA coef/10000*0d0/

      DATA (((icol(i,j,k),k=1,2),j=1,4),i=1,40)/

     &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,

     &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,

     &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,

     &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,

     &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,

     &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,

     &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,

     &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,

     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,

     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/


C...Treatment of resonances.

      DATA (mwid(i)  ,i=   1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,

     &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*0/


C...Character constants: name of processes.

      DATA proc(0)/                    'All included subprocesses   '/

      DATA (proc(i),i=1,20)/

     &'f + fbar -> gamma*/Z0       ',  'f + fbar'' -> W+/-           ',

     &'f + fbar -> h0              ',  'gamma + W+/- -> W+/-        ',

     &'Z0 + Z0 -> h0               ',  'Z0 + W+/- -> W+/-           ',

     &'                            ',  'W+ + W- -> h0               ',

     &'                            ',  'f + f'' -> f + f'' (QFD)      ',

     1'f + f'' -> f + f'' (QCD)      ','f + fbar -> f'' + fbar''      ',

     1'f + fbar -> g + g           ',  'f + fbar -> g + gamma       ',

     1'f + fbar -> g + Z0          ',  'f + fbar'' -> g + W+/-       ',

     1'f + fbar -> g + h0          ',  'f + fbar -> gamma + gamma   ',

     1'f + fbar -> gamma + Z0      ',  'f + fbar'' -> gamma + W+/-   '/

      DATA (proc(i),i=21,40)/

     2'f + fbar -> gamma + h0      ',  'f + fbar -> Z0 + Z0         ',

     2'f + fbar'' -> Z0 + W+/-      ', 'f + fbar -> Z0 + h0         ',

     2'f + fbar -> W+ + W-         ',  'f + fbar'' -> W+/- + h0      ',

     2'f + fbar -> h0 + h0         ',  'f + g -> f + g              ',

     2'f + g -> f + gamma          ',  'f + g -> f + Z0             ',

     3'f + g -> f'' + W+/-          ', 'f + g -> f + h0             ',

     3'f + gamma -> f + g          ',  'f + gamma -> f + gamma      ',

     3'f + gamma -> f + Z0         ',  'f + gamma -> f'' + W+/-      ',

     3'f + gamma -> f + h0         ',  'f + Z0 -> f + g             ',

     3'f + Z0 -> f + gamma         ',  'f + Z0 -> f + Z0            '/

      DATA (proc(i),i=41,60)/

     4'f + Z0 -> f'' + W+/-         ', 'f + Z0 -> f + h0            ',

     4'f + W+/- -> f'' + g          ', 'f + W+/- -> f'' + gamma      ',

     4'f + W+/- -> f'' + Z0         ', 'f + W+/- -> f'' + W+/-       ',

     4'f + W+/- -> f'' + h0         ', 'f + h0 -> f + g             ',

     4'f + h0 -> f + gamma         ',  'f + h0 -> f + Z0            ',

     5'f + h0 -> f'' + W+/-         ', 'f + h0 -> f + h0            ',

     5'g + g -> f + fbar           ',  'g + gamma -> f + fbar       ',

     5'g + Z0 -> f + fbar          ',  'g + W+/- -> f + fbar''       ',

     5'g + h0 -> f + fbar          ',  'gamma + gamma -> f + fbar   ',

     5'gamma + Z0 -> f + fbar      ',  'gamma + W+/- -> f + fbar''   '/

      DATA (proc(i),i=61,80)/

     6'gamma + h0 -> f + fbar      ',  'Z0 + Z0 -> f + fbar         ',

     6'Z0 + W+/- -> f + fbar''      ', 'Z0 + h0 -> f + fbar         ',

     6'W+ + W- -> f + fbar         ',  'W+/- + h0 -> f + fbar''      ',

     6'h0 + h0 -> f + fbar         ',  'g + g -> g + g              ',

     6'gamma + gamma -> W+ + W-    ',  'gamma + W+/- -> Z0 + W+/-   ',

     7'Z0 + Z0 -> Z0 + Z0          ',  'Z0 + Z0 -> W+ + W-          ',

     7'Z0 + W+/- -> Z0 + W+/-      ',  'Z0 + Z0 -> Z0 + h0          ',

     7'W+ + W- -> gamma + gamma    ',  'W+ + W- -> Z0 + Z0          ',

     7'W+/- + W+/- -> W+/- + W+/-  ',  'W+/- + h0 -> W+/- + h0      ',

     7'h0 + h0 -> h0 + h0          ',  'q + gamma -> q'' + pi+/-     '/

      DATA (proc(i),i=81,100)/

     8'q + qbar -> Q + Qbar, mass  ',  'g + g -> Q + Qbar, massive  ',

     8'f + q -> f'' + Q, massive    ', 'g + gamma -> Q + Qbar, mass ',

     8'gamma + gamma -> F + Fbar, m',  'g + g -> J/Psi + g          ',

     8'g + g -> chi_0c + g         ',  'g + g -> chi_1c + g         ',

     8'g + g -> chi_2c + g         ',  '                            ',

     9'Elastic scattering          ',  'Single diffractive (XB)     ',

     9'Single diffractive (AX)     ',  'Double  diffractive         ',

     9'Low-pT scattering           ',  'Semihard QCD 2 -> 2         ',

     9'                            ',  '                            ',

     9'                            ',  '                            '/

      DATA (proc(i),i=101,120)/

     &'g + g -> gamma*/Z0          ',  'g + g -> h0                 ',

     &'gamma + gamma -> h0         ',  '                            ',

     &'                            ',  '                            ',

     &'                            ',  '                            ',

     &'                            ',  'f + fbar -> gamma + h0      ',

     1'f + fbar -> g + h0          ',  'q + g -> q + h0             ',

     1'g + g -> g + h0             ',  'g + g -> gamma + gamma      ',

     1'g + g -> g + gamma          ',  'g + g -> gamma + Z0         ',

     1'g + g -> Z0 + Z0            ',  'g + g -> W+ + W-            ',

     1'                            ',  '                            '/

      DATA (proc(i),i=121,140)/

     2'g + g -> Q + Qbar + h0      ',  'q + qbar -> Q + Qbar + h0   ',

     2'f + f'' -> f + f'' + h0       ',

     2'f + f'' -> f" + f"'' + h0     ',

     2'                            ',  '                            ',

     2'                            ',  '                            ',

     2'                            ',  '                            ',

     3'g + g -> Z0 + q + qbar      ',  '                            ',

     3'                            ',  '                            ',

     3'                            ',  '                            ',

     3'                            ',  '                            ',

     3'                            ',  '                            '/

      DATA (proc(i),i=141,160)/

     4'f + fbar -> gamma*/Z0/Z''0   ', 'f + fbar'' -> W''+/-          ',

     4'f + fbar'' -> H+/-           ', 'f + fbar'' -> R              ',

     4'q + l -> LQ                 ',  '                            ',

     4'd + g -> d*                 ',  'u + g -> u*                 ',

     4'g + g -> eta_techni         ',  '                            ',

     5'f + fbar -> H0              ',  'g + g -> H0                 ',

     5'gamma + gamma -> H0         ',  '                            ',

     5'                            ',  'f + fbar -> A0              ',

     5'g + g -> A0                 ',  'gamma + gamma -> A0         ',

     5'                            ',  '                            '/

      DATA (proc(i),i=161,180)/

     6'f + g -> f'' + H+/-          ', 'q + g -> LQ + lbar          ',

     6'g + g -> LQ + LQbar         ',  'q + qbar -> LQ + LQbar      ',

     6'f + fbar -> f'' + fbar'' (g/Z)',

     6'f +fbar'' -> f" + fbar"'' (W) ',

     6'q + q'' -> q" + d*           ',  'q + q'' -> q" + u*           ',

     6'                            ',  '                            ',

     7'f + fbar -> Z0 + H0         ', 'f + fbar'' -> W+/- + H0      ',

     7'f + f'' -> f + f'' + H0       ',

     7'f + f'' -> f" + f"'' + H0     ',

     7'                            ',  'f + fbar -> Z0 + A0         ',

     7'f + fbar'' -> W+/- + A0      ',

     7'f + f'' -> f + f'' + A0       ',

     7'f + f'' -> f" + f"'' + A0     ',

     7'                            '/

      DATA (proc(i),i=181,200)/

     8'g + g -> Q + Qbar + H0      ',  'q + qbar -> Q + Qbar + H0   ',

     8'                            ',  '                            ',

     8'                            ',  'g + g -> Q + Qbar + A0      ',

     8'q + qbar -> Q + Qbar + A0   ',  '                            ',

     8'                            ',  '                            ',

     9'f + fbar -> rho_tech0       ',  'f + f'' -> rho_tech+/-       ',

     9'f + fbar -> omega_tech0     ',  'f+fbar -> f''+fbar'' (technic)',

     9'                            ',  '                            ',

     9'                            ',  '                            ',

     9'                            ',  '                            '/

      DATA (proc(i),i=201,220)/

     &'f + fbar -> ~e_L + ~e_Lbar  ',  'f + fbar -> ~e_R + ~e_Rbar  ',

     &'f + fbar -> ~e_R + ~e_Lbar  ',  'f + fbar -> ~mu_L + ~mu_Lbar',

     &'f + fbar -> ~mu_R + ~mu_Rbar',  'f + fbar -> ~mu_L + ~mu_Rbar',

     &'f+fbar -> ~tau_1 + ~tau_1bar',  'f+fbar -> ~tau_2 + ~tau_2bar',

     &'f+fbar -> ~tau_1 + ~tau_2bar',  'q + qbar'' -> ~l_L + ~nulbar ',

     1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',

     1'f + fbar -> ~nul + ~nulbar  ',  'f+fbar -> ~nutau + ~nutaubar',

     1'                            ',  'f + fbar -> ~chi1 + ~chi1   ',

     1'f + fbar -> ~chi2 + ~chi2   ',  'f + fbar -> ~chi3 + ~chi3   ',

     1'f + fbar -> ~chi4 + ~chi4   ',  'f + fbar -> ~chi1 + ~chi2   '/

      DATA (proc(i),i=221,240)/

     2'f + fbar -> ~chi1 + ~chi3   ',  'f + fbar -> ~chi1 + ~chi4   ',

     2'f + fbar -> ~chi2 + ~chi3   ',  'f + fbar -> ~chi2 + ~chi4   ',

     2'f + fbar -> ~chi3 + ~chi4   ',  'f+fbar -> ~chi+-1 + ~chi-+1 ',

     2'f+fbar -> ~chi+-2 + ~chi-+2 ',  'f+fbar -> ~chi+-1 + ~chi-+2 ',

     2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',

     3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',

     3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',

     3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',

     3'q + qbar -> ~chi1 + ~g      ',  'q + qbar -> ~chi2 + ~g      ',

     3'q + qbar -> ~chi3 + ~g      ',  'q + qbar -> ~chi4 + ~g      '/

      DATA (proc(i),i=241,260)/

     4'q + qbar'' -> ~chi+-1 + ~g   ', 'q + qbar'' -> ~chi+-2 + ~g  ',

     4'q + qbar -> ~g + ~g         ',  'g + g -> ~g + ~g            ',

     4'                            ',  'qj + g -> ~qj_L + ~chi1     ',

     4'qj + g -> ~qj_R + ~chi1     ',  'qj + g -> ~qj_L + ~chi2     ',

     4'qj + g -> ~qj_R + ~chi2     ',  'qj + g -> ~qj_L + ~chi3     ',

     5'qj + g -> ~qj_R + ~chi3     ',  'qj + g -> ~qj_L + ~chi4     ',

     5'qj + g -> ~qj_R + ~chi4     ',  'qj + g -> ~qk_L + ~chi+-1   ',

     5'qj + g -> ~qk_R + ~chi+-1   ',  'qj + g -> ~qk_L + ~chi+-2   ',

     5'qj + g -> ~qk_R + ~chi+-2   ',  'qj + g -> ~qj_L + ~g        ',

     5'qj + g -> ~qj_R + ~g        ',  '                            '/

      DATA (proc(i),i=261,280)/

     6'f + fbar -> ~t_1 + ~t_1bar  ',  'f + fbar -> ~t_2 + ~t_2bar  ',

     6'f + fbar -> ~t_1 + ~t_2bar  ',  'g + g -> ~t_1 + ~t_1bar     ',

     6'g + g -> ~t_2 + ~t_2bar     ',  '                            ',

     6'                            ',  '                            ',

     6'                            ',  '                            ',

     7'qi + qj -> ~qi_L + ~qj_L    ',  'qi + qj -> ~qi_R + ~qj_R    ',

     7'qi + qj -> ~qi_L + ~qj_R    ',  'qi+qjbar -> ~qi_L + ~qj_Lbar',

     7'qi+qjbar -> ~qi_R + ~qj_Rbar',  'qi+qjbar -> ~qi_L + ~qj_Rbar',

     7'f + fbar -> ~qi_L + ~qi_Lbar',  'f + fbar -> ~qi_R + ~qi_Rbar',

     7'g + g -> ~qi_L + ~qi_Lbar   ',  'g + g -> ~qi_R + ~qi_Rbar   '/

      DATA (proc(i),i=281,500)/220*'                            '/


C...Cross sections and slope offsets.

      DATA sigt/294*0d0/


C...Supersymmetry switches and parameters.

      DATA imss/0,

     &  0,  0,  0,  1,  0,  0,  0,  1,  0,  0,

     1  89*0/

      DATA rmss/0d0,

     &  80d0,160d0,500d0,800d0,2d0,250d0,200d0,800d0,700d0,800d0,

     1  700d0,500d0,250d0,200d0,800d0,400d0,0d0,0.1d0,850d0,0.041d0,

     2   1d0,800d0,1d4,1d4,1d4,0d0,0d0,24d17,2*0d0,

     3  69*0d0/


C...Data for histogramming routines.

      DATA ihist/1000,20000,55,1/

      DATA indx/1000*0/


      END


C*********************************************************************


C...PYTEST

C...A simple program (disguised as subroutine) to run at installation

C...as a check that the program works as intended.


      SUBROUTINE pytest(MTEST)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/

C...Local arrays.

      dimension psum(5),pini(6),pfin(6)


C...Save defaults for values that are changed.

      mstj1=mstj(1)

      mstj3=mstj(3)

      mstj11=mstj(11)

      mstj42=mstj(42)

      mstj43=mstj(43)

      mstj44=mstj(44)

      parj17=parj(17)

      parj22=parj(22)

      parj43=parj(43)

      parj54=parj(54)

      mst101=mstj(101)

      mst104=mstj(104)

      mst105=mstj(105)

      mst107=mstj(107)

      mst116=mstj(116)


C...First part: loop over simple events to be generated.

      IF(mtest.GE.1) CALL pytabu(20)

      nerr=0

      DO 180 iev=1,500


C...Reset parameter values. Switch on some nonstandard features.

        mstj(1)=1

        mstj(3)=0

        mstj(11)=1

        mstj(42)=2

        mstj(43)=4

        mstj(44)=2

        parj(17)=0.1d0

        parj(22)=1.5d0

        parj(43)=1d0

        parj(54)=-0.05d0

        mstj(101)=5

        mstj(104)=5

        mstj(105)=0

        mstj(107)=1

        IF(iev.EQ.301.OR.iev.EQ.351.OR.iev.EQ.401) mstj(116)=3


C...Ten events each for some single jets configurations.

        IF(iev.LE.50) THEN

          ity=(iev+9)/10

          mstj(3)=-1

          IF(ity.EQ.3.OR.ity.EQ.4) mstj(11)=2

          IF(ity.EQ.1) CALL py1ent(1,1,15d0,0d0,0d0)

          IF(ity.EQ.2) CALL py1ent(1,3101,15d0,0d0,0d0)

          IF(ity.EQ.3) CALL py1ent(1,-2203,15d0,0d0,0d0)

          IF(ity.EQ.4) CALL py1ent(1,-4,30d0,0d0,0d0)

          IF(ity.EQ.5) CALL py1ent(1,21,15d0,0d0,0d0)


C...Ten events each for some simple jet systems; string fragmentation.

        ELSEIF(iev.LE.130) THEN

          ity=(iev-41)/10

          IF(ity.EQ.1) CALL py2ent(1,1,-1,40d0)

          IF(ity.EQ.2) CALL py2ent(1,4,-4,30d0)

          IF(ity.EQ.3) CALL py2ent(1,2,2103,100d0)

          IF(ity.EQ.4) CALL py2ent(1,21,21,40d0)

          IF(ity.EQ.5) CALL py3ent(1,2101,21,-3203,30d0,0.6d0,0.8d0)

          IF(ity.EQ.6) CALL py3ent(1,5,21,-5,40d0,0.9d0,0.8d0)

          IF(ity.EQ.7) CALL py3ent(1,21,21,21,60d0,0.7d0,0.5d0)

          IF(ity.EQ.8) CALL py4ent(1,2,21,21,-2,40d0,

     &    0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)


C...Seventy events with independent fragmentation and momentum cons.

        ELSEIF(iev.LE.200) THEN

          ity=1+(iev-131)/16

          mstj(2)=1+mod(iev-131,4)

          mstj(3)=1+mod((iev-131)/4,4)

          IF(ity.EQ.1) CALL py2ent(1,4,-5,40d0)

          IF(ity.EQ.2) CALL py3ent(1,3,21,-3,40d0,0.9d0,0.4d0)

          IF(ity.EQ.3) CALL py4ent(1,2,21,21,-2,40d0,

     &    0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)

          IF(ity.GE.4) CALL py4ent(1,2,-3,3,-2,40d0,

     &    0.4d0,0.64d0,0.6d0,0.12d0,0.2d0)


C...A hundred events with random jets (check invariant mass).

        ELSEIF(iev.LE.300) THEN

  100     DO 110 j=1,5

            psum(j)=0d0

  110     CONTINUE

          njet=2d0+6d0*pyr(0)

          DO 130 i=1,njet

            kfl=21

            IF(i.EQ.1) kfl=int(1d0+4d0*pyr(0))

            IF(i.EQ.njet) kfl=-int(1d0+4d0*pyr(0))

            ejet=5d0+20d0*pyr(0)

            theta=acos(2d0*pyr(0)-1d0)

            phi=6.2832d0*pyr(0)

            IF(i.LT.njet) CALL py1ent(-i,kfl,ejet,theta,phi)

            IF(i.EQ.njet) CALL py1ent(i,kfl,ejet,theta,phi)

            IF(i.EQ.1.OR.i.EQ.njet) mstj(93)=1

            IF(i.EQ.1.OR.i.EQ.njet) psum(5)=psum(5)+pymass(kfl)

            DO 120 j=1,4

              psum(j)=psum(j)+p(i,j)

  120       CONTINUE

  130     CONTINUE

          IF(psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2.LT.

     &    (psum(5)+parj(32))**2) goto 100


C...Fifty e+e- continuum events with matrix elements.

        ELSEIF(iev.LE.350) THEN

          mstj(101)=2

          CALL pyeevt(0,40d0)


C...Fifty e+e- continuum event with varying shower options.

        ELSEIF(iev.LE.400) THEN

          mstj(42)=1+mod(iev,2)

          mstj(43)=1+mod(iev/2,4)

          mstj(44)=mod(iev/8,3)

          CALL pyeevt(0,90d0)


C...Fifty e+e- continuum events with coherent shower.

        ELSEIF(iev.LE.450) THEN

          CALL pyeevt(0,500d0)


C...Fifty Upsilon decays to ggg or gammagg with coherent shower.

        ELSE

          CALL pyonia(5,9.46d0)

        ENDIF


C...Generate event. Find total momentum, energy and charge.

        DO 140 j=1,4

          pini(j)=pyp(0,j)

  140   CONTINUE

        pini(6)=pyp(0,6)

        CALL pyexec

        DO 150 j=1,4

          pfin(j)=pyp(0,j)

  150   CONTINUE

        pfin(6)=pyp(0,6)


C...Check conservation of energy, momentum and charge;

C...usually exact, but only approximate for single jets.

        merr=0

        IF(iev.LE.50) THEN

          IF((pfin(1)-pini(1))**2+(pfin(2)-pini(2))**2.GE.4d0)

     &    merr=merr+1

          epzrem=pini(4)+pini(3)-pfin(4)-pfin(3)

          IF(epzrem.LT.0d0.OR.epzrem.GT.2d0*parj(31)) merr=merr+1

          IF(abs(pfin(6)-pini(6)).GT.2.1d0) merr=merr+1

        ELSE

          DO 160 j=1,4

            IF(abs(pfin(j)-pini(j)).GT.0.0001d0*pini(4)) merr=merr+1

  160     CONTINUE

          IF(abs(pfin(6)-pini(6)).GT.0.1d0) merr=merr+1

        ENDIF

        IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),

     &  (pfin(j),j=1,4),pfin(6)


C...Check that all KF codes are known ones, and that partons/particles

C...satisfy energy-momentum-mass relation. Store particle statistics.

        DO 170 i=1,n

          IF(k(i,1).GT.20) goto 170

          IF(pycomp(k(i,2)).EQ.0) THEN

            WRITE(mstu(11),5100) i

            merr=merr+1

          ENDIF

          pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2

          IF(abs(pd).GT.max(0.1d0,0.001d0*p(i,4)**2).OR.p(i,4).LT.0d0)

     &    THEN

            WRITE(mstu(11),5200) i

            merr=merr+1

          ENDIF

  170   CONTINUE

        IF(mtest.GE.1) CALL pytabu(21)


C...List all erroneous events and some normal ones.

        IF(merr.NE.0.OR.mstu(24).NE.0.OR.mstu(28).NE.0) THEN

          IF(merr.GE.1) WRITE(mstu(11),6400)

          CALL pylist(2)

        ELSEIF(mtest.GE.1.AND.mod(iev-5,100).EQ.0) THEN

          CALL pylist(1)

        ENDIF


C...Stop execution if too many errors.

        IF(merr.NE.0) nerr=nerr+1

        IF(nerr.GE.10) THEN

          WRITE(mstu(11),6300)

          CALL pylist(1)

          stop

        ENDIF

  180 CONTINUE


C...Summarize result of run.

      IF(mtest.GE.1) CALL pytabu(22)


C...Reset commonblock variables changed during run.

      mstj(1)=mstj1

      mstj(3)=mstj3

      mstj(11)=mstj11

      mstj(42)=mstj42

      mstj(43)=mstj43

      mstj(44)=mstj44

      parj(17)=parj17

      parj(22)=parj22

      parj(43)=parj43

      parj(54)=parj54

      mstj(101)=mst101

      mstj(104)=mst104

      mstj(105)=mst105

      mstj(107)=mst107

      mstj(116)=mst116


C...Second part: complete events of various kinds.

C...Common initial values. Loop over initiating conditions.

      mstp(122)=max(0,min(2,mtest))

      mdcy(pycomp(111),1)=0

      DO 230 iproc=1,8


C...Reset process type, kinematics cuts, and the flags used.

        msel=0

        DO 190 isub=1,500

          msub(isub)=0

  190   CONTINUE

        ckin(1)=2d0

        ckin(3)=0d0

        mstp(2)=1

        mstp(11)=0

        mstp(33)=0

        mstp(81)=1

        mstp(82)=1

        mstp(111)=1

        mstp(131)=0

        mstp(133)=0

        parp(131)=0.01d0


C...Prompt photon production at fixed target.

        IF(iproc.EQ.1) THEN

          pzsum=300d0

          pesum=sqrt(pzsum**2+pymass(211)**2)+pymass(2212)

          pqsum=2d0

          msel=10

          ckin(3)=5d0

          CALL pyinit('FIXT','pi+','p',pzsum)


C...QCD processes at ISR energies.

        ELSEIF(iproc.EQ.2) THEN

          pesum=63d0

          pzsum=0d0

          pqsum=2d0

          msel=1

          ckin(3)=5d0

          CALL pyinit('CMS','p','p',pesum)


C...W production + multiple interactions at CERN Collider.

        ELSEIF(iproc.EQ.3) THEN

          pesum=630d0

          pzsum=0d0

          pqsum=0d0

          msel=12

          ckin(1)=20d0

          mstp(82)=4

          mstp(2)=2

          mstp(33)=3

          CALL pyinit('CMS','p','pbar',pesum)


C...W/Z gauge boson pairs + pileup events at the Tevatron.

        ELSEIF(iproc.EQ.4) THEN

          pesum=1800d0

          pzsum=0d0

          pqsum=0d0

          msub(22)=1

          msub(23)=1

          msub(25)=1

          ckin(1)=200d0

          mstp(111)=0

          mstp(131)=1

          mstp(133)=2

          parp(131)=0.04d0

          CALL pyinit('CMS','p','pbar',pesum)


C...Higgs production at LHC.

        ELSEIF(iproc.EQ.5) THEN

          pesum=15400d0

          pzsum=0d0

          pqsum=2d0

          msub(3)=1

          msub(102)=1

          msub(123)=1

          msub(124)=1

          pmas(25,1)=300d0

          ckin(1)=200d0

          mstp(81)=0

          mstp(111)=0

          CALL pyinit('CMS','p','p',pesum)


C...Z' production at SSC.

        ELSEIF(iproc.EQ.6) THEN

          pesum=40000d0

          pzsum=0d0

          pqsum=2d0

          msel=21

          pmas(32,1)=600d0

          ckin(1)=400d0

          mstp(81)=0

          mstp(111)=0

          CALL pyinit('CMS','p','p',pesum)


C...W pair production at 1 TeV e+e- collider.

        ELSEIF(iproc.EQ.7) THEN

          pesum=1000d0

          pzsum=0d0

          pqsum=0d0

          msub(25)=1

          msub(69)=1

          mstp(11)=1

          CALL pyinit('CMS','e+','e-',pesum)


C...Deep inelastic scattering at a LEP+LHC ep collider.

        ELSEIF(iproc.EQ.8) THEN

          p(1,1)=0d0

          p(1,2)=0d0

          p(1,3)=8000d0

          p(2,1)=0d0

          p(2,2)=0d0

          p(2,3)=-80d0

          pesum=8080d0

          pzsum=7920d0

          pqsum=0d0

          msub(10)=1

          ckin(3)=50d0

          mstp(111)=0

          CALL pyinit('USER','p','e-',pesum)

        ENDIF


C...Generate 20 events of each required type.

        DO 220 iev=1,20

          CALL pyevnt

          pesumm=pesum

          IF(iproc.EQ.4) pesumm=msti(41)*pesum


C...Check conservation of energy/momentum/flavour.

          pini(1)=0d0

          pini(2)=0d0

          pini(3)=pzsum

          pini(4)=pesumm

          pini(6)=pqsum

          DO 200 j=1,4

            pfin(j)=pyp(0,j)

  200     CONTINUE

          pfin(6)=pyp(0,6)

          merr=0

          deve=abs(pfin(4)-pini(4))+abs(pfin(3)-pini(3))

          devt=abs(pfin(1)-pini(1))+abs(pfin(2)-pini(2))

          devq=abs(pfin(6)-pini(6))

          IF(deve.GT.2d-3*pesum.OR.devt.GT.max(0.01d0,1d-4*pesum).OR.

     &    devq.GT.0.1d0) merr=1

          IF(merr.NE.0) WRITE(mstu(11),5000) (pini(j),j=1,4),pini(6),

     &    (pfin(j),j=1,4),pfin(6)


C...Check that all KF codes are known ones, and that partons/particles

C...satisfy energy-momentum-mass relation.

          DO 210 i=1,n

            IF(k(i,1).GT.20) goto 210

            IF(pycomp(k(i,2)).EQ.0) THEN

              WRITE(mstu(11),5100) i

              merr=merr+1

            ENDIF

            pd=p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2-p(i,5)**2*

     &      sign(1d0,p(i,5))

            IF(abs(pd).GT.max(0.1d0,0.002d0*p(i,4)**2,0.002d0*p(i,5)**2)

     &      .OR.(p(i,5).GE.0d0.AND.p(i,4).LT.0d0)) THEN

              WRITE(mstu(11),5200) i

              merr=merr+1

            ENDIF

  210     CONTINUE


C...Listing of erroneous events, and first event of each type.

          IF(merr.GE.1) nerr=nerr+1

          IF(nerr.GE.10) THEN

            WRITE(mstu(11),6300)

            CALL pylist(1)

            stop

          ENDIF

          IF(mtest.GE.1.AND.(merr.GE.1.OR.iev.EQ.1)) THEN

            IF(merr.GE.1) WRITE(mstu(11),6400)

            CALL pylist(1)

          ENDIF

  220   CONTINUE


C...List statistics for each process type.

        IF(mtest.GE.1) CALL pystat(1)

  230 CONTINUE


C...Summarize result of run.

      IF(nerr.EQ.0) WRITE(mstu(11),6500)

      IF(nerr.GT.0) WRITE(mstu(11),6600) nerr


C...Format statements for output.

 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',

     &'in following event'/' sum of',9x,'px',11x,'py',11x,'pz',11x,

     &'E',8x,'charge'/' before',2x,4(1x,f12.5),1x,f8.2/' after',3x,

     &4(1x,f12.5),1x,f8.2)

 5100 FORMAT(/5x,'Entry no.',i4,' in following event not known code')

 5200 FORMAT(/5x,'Entry no.',i4,' in following event has faulty ',

     &'kinematics')

 6300 FORMAT(/5x,'This is the tenth error experienced! Something is ',

     &'wrong.'/5x,'Execution will be stopped after listing of event.')

 6400 FORMAT(5x,'Faulty event follows:')

 6500 FORMAT(//5x,'End result of PYTEST: no errors detected.')

 6600 FORMAT(//5x,'End result of PYTEST:',i2,' errors detected.'/

     &5x,'This should not have happened!')


      RETURN

      END


C*********************************************************************


C...PYHEPC

C...Converts PYTHIA event record contents to or from

C...the standard event record commonblock.


      SUBROUTINE pyhepc(MCONV)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...HEPEVT commonblock.

      parameter(nmxhep=4000)

      common/hepevt/nevhep,nhep,isthep(nmxhep),idhep(nmxhep),

     &jmohep(2,nmxhep),jdahep(2,nmxhep),phep(5,nmxhep),vhep(4,nmxhep)

      DOUBLE PRECISION phep,vhep

      SAVE /hepevt/


C...Conversion from PYTHIA to standard, the easy part.

      IF(mconv.EQ.1) THEN

        nevhep=0

        IF(n.GT.nmxhep) CALL pyerrm(8,

     &  '(PYHEPC:) no more space in /HEPEVT/')

        nhep=min(n,nmxhep)

        DO 140 i=1,nhep

          isthep(i)=0

          IF(k(i,1).GE.1.AND.k(i,1).LE.10) isthep(i)=1

          IF(k(i,1).GE.11.AND.k(i,1).LE.20) isthep(i)=2

          IF(k(i,1).GE.21.AND.k(i,1).LE.30) isthep(i)=3

          IF(k(i,1).GE.31.AND.k(i,1).LE.100) isthep(i)=k(i,1)

          idhep(i)=k(i,2)

          jmohep(1,i)=k(i,3)

          jmohep(2,i)=0

          IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN

            jdahep(1,i)=k(i,4)

            jdahep(2,i)=k(i,5)

          ELSE

            jdahep(1,i)=0

            jdahep(2,i)=0

          ENDIF

          DO 100 j=1,5

            phep(j,i)=p(i,j)

  100     CONTINUE

          DO 110 j=1,4

            vhep(j,i)=v(i,j)

  110     CONTINUE


C...Check if new event (from pileup).

          IF(i.EQ.1) THEN

            inew=1

          ELSE

            IF(k(i,1).EQ.21.AND.k(i-1,1).NE.21) inew=i

          ENDIF


C...Fill in missing mother information.

          IF(i.GE.inew+2.AND.k(i,1).EQ.21.AND.k(i,3).EQ.0) THEN

            imo1=i-2

            IF(i.GE.inew+3.AND.k(i-1,1).EQ.21.AND.k(i-1,3).EQ.0)

     &      imo1=imo1-1

            jmohep(1,i)=imo1

            jmohep(2,i)=imo1+1

          ELSEIF(k(i,2).GE.91.AND.k(i,2).LE.93) THEN

            i1=k(i,3)-1

  120       i1=i1+1

            IF(i1.GE.i) CALL pyerrm(8,

     &      '(PYHEPC:) translation of inconsistent event history')

            IF(i1.LT.i.AND.k(i1,1).NE.1.AND.k(i1,1).NE.11) goto 120

            kc=pycomp(k(i1,2))

            IF(i1.LT.i.AND.kc.EQ.0) goto 120

            IF(i1.LT.i.AND.kchg(kc,2).EQ.0) goto 120

            jmohep(2,i)=i1

          ELSEIF(k(i,2).EQ.94) THEN

            njet=2

            IF(nhep.GE.i+3.AND.k(i+3,3).LE.i) njet=3

            IF(nhep.GE.i+4.AND.k(i+4,3).LE.i) njet=4

            jmohep(2,i)=mod(k(i+njet,4)/mstu(5),mstu(5))

            IF(jmohep(2,i).EQ.jmohep(1,i)) jmohep(2,i)=

     &      mod(k(i+1,4)/mstu(5),mstu(5))

          ENDIF


C...Fill in missing daughter information.

          IF(k(i,2).EQ.94.AND.mstu(16).NE.2) THEN

            DO 130 i1=jdahep(1,i),jdahep(2,i)

              i2=mod(k(i1,4)/mstu(5),mstu(5))

              jdahep(1,i2)=i

  130       CONTINUE

          ENDIF

          IF(k(i,2).GE.91.AND.k(i,2).LE.94) goto 140

          i1=jmohep(1,i)

          IF(i1.LE.0.OR.i1.GT.nhep) goto 140

          IF(k(i1,1).NE.13.AND.k(i1,1).NE.14) goto 140

          IF(jdahep(1,i1).EQ.0) THEN

            jdahep(1,i1)=i

          ELSE

            jdahep(2,i1)=i

          ENDIF

  140   CONTINUE

        DO 150 i=1,nhep

          IF(k(i,1).NE.13.AND.k(i,1).NE.14) goto 150

          IF(jdahep(2,i).EQ.0) jdahep(2,i)=jdahep(1,i)

  150   CONTINUE


C...Conversion from standard to PYTHIA, the easy part.

      ELSE

        IF(nhep.GT.mstu(4)) CALL pyerrm(8,

     &  '(PYHEPC:) no more space in /PYJETS/')

        n=min(nhep,mstu(4))

        nkq=0

        kqsum=0

        DO 180 i=1,n

          k(i,1)=0

          IF(isthep(i).EQ.1) k(i,1)=1

          IF(isthep(i).EQ.2) k(i,1)=11

          IF(isthep(i).EQ.3) k(i,1)=21

          k(i,2)=idhep(i)

          k(i,3)=jmohep(1,i)

          k(i,4)=jdahep(1,i)

          k(i,5)=jdahep(2,i)

          DO 160 j=1,5

            p(i,j)=phep(j,i)

  160     CONTINUE

          DO 170 j=1,4

            v(i,j)=vhep(j,i)

  170     CONTINUE

          v(i,5)=0d0

          IF(isthep(i).EQ.2.AND.phep(4,i).GT.phep(5,i)) THEN

            i1=jdahep(1,i)

            IF(i1.GT.0.AND.i1.LE.nhep) v(i,5)=(vhep(4,i1)-vhep(4,i))*

     &      phep(5,i)/phep(4,i)

          ENDIF


C...Fill in missing information on colour connection in jet systems.

          IF(isthep(i).EQ.1) THEN

            kc=pycomp(k(i,2))

            kq=0

            IF(kc.NE.0) kq=kchg(kc,2)*isign(1,k(i,2))

            IF(kq.NE.0) nkq=nkq+1

            IF(kq.NE.2) kqsum=kqsum+kq

            IF(kq.NE.0.AND.kqsum.NE.0) THEN

              k(i,1)=2

            ELSEIF(kq.EQ.2.AND.i.LT.n) THEN

              IF(k(i+1,2).EQ.21) k(i,1)=2

            ENDIF

          ENDIF

  180   CONTINUE

        IF(nkq.EQ.1.OR.kqsum.NE.0) CALL pyerrm(8,

     &  '(PYHEPC:) input parton configuration not colour singlet')

      ENDIF


      END


C*********************************************************************


C...PYINIT

C...Initializes the generation procedure; finds maxima of the

C...differential cross-sections to be used for weighting.


      SUBROUTINE pyinit(FRAME,BEAM,TARGET,WIN)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/,/pyint5/

C...Local arrays and character variables.

      dimension alamin(20),nfin(20)

      CHARACTER*(*) frame,beam,target

      CHARACTER chfram*8,chbeam*8,chtarg*8,chlh(2)*6


C...Interface to PDFLIB.

      common/w50512/qcdl4,qcdl5

      SAVE /w50512/

      DOUBLE PRECISION value(20),qcdl4,qcdl5

      CHARACTER*20 parm(20)

      DATA value/20*0d0/,parm/20*' '/


C...Data:Lambda and n_f values for parton distributions; months.

      DATA alamin/0.177d0,0.239d0,0.247d0,0.2322d0,0.248d0,0.248d0,

     &14*0.2d0/,nfin/20*4/

      DATA chlh/'lepton','hadron'/


C...Reset MINT and VINT arrays. Write headers.

      DO 100 j=1,400

        mint(j)=0

        vint(j)=0d0

  100 CONTINUE

      IF(mstu(12).GE.1) CALL pylist(0)

      IF(mstp(122).GE.1) WRITE(mstu(11),5100)


C...Maximum 4 generations; set maximum number of allowed flavours.

      mstp(1)=min(4,mstp(1))

      mstu(114)=min(mstu(114),2*mstp(1))

      mstp(58)=min(mstp(58),2*mstp(1))


C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.

      DO 120 i=-20,20

        vint(180+i)=0d0

        ia=iabs(i)

        IF(ia.GE.1.AND.ia.LE.2*mstp(1)) THEN

          DO 110 j=1,mstp(1)

            ib=2*j-1+mod(ia,2)

            IF(ib.GE.6.AND.mstp(9).EQ.0) goto 110

            ipm=(5-isign(1,i))/2

            idc=j+mdcy(ia,2)+2

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) vint(180+i)=

     &      vint(180+i)+vckm((ia+1)/2,(ib+1)/2)

  110     CONTINUE

        ELSEIF(ia.GE.11.AND.ia.LE.10+2*mstp(1)) THEN

          vint(180+i)=1d0

        ENDIF

  120 CONTINUE


C...Initialize parton distributions: PDFLIB.

      IF(mstp(52).EQ.2) THEN

        parm(1)='NPTYPE'

        value(1)=1

        parm(2)='NGROUP'

        value(2)=mstp(51)/1000

        parm(3)='NSET'

        value(3)=mod(mstp(51),1000)

        parm(4)='TMAS'

        value(4)=pmas(6,1)

        CALL pdfset(parm,value)

        mint(93)=1000000+mstp(51)

      ENDIF


C...Choose Lambda value to use in alpha-strong.

      mstu(111)=mstp(2)

      IF(mstp(3).GE.2) THEN

        alam=0.2d0

        nf=4

        IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.10) THEN

          alam=alamin(mstp(51))

          nf=nfin(mstp(51))

        ELSEIF(mstp(52).EQ.2) THEN

          alam=qcdl4

          nf=4

        ENDIF

        parp(1)=alam

        parp(61)=alam

        parp(72)=alam

        paru(112)=alam

        mstu(112)=nf

        IF(mstp(3).EQ.3) parj(81)=alam

      ENDIF


C...Initialize the SUSY generation: couplings, masses,

C...decay modes, branching ratios, and so on.

      CALL pymsin


C...Initialize widths and partial widths for resonances.

      CALL pyinre

C...Set Z0 mass and width for e+e- routines.

      parj(123)=pmas(23,1)

      parj(124)=pmas(23,2)


C...Identify beam and target particles and frame of process.

      chfram=frame//' '

      chbeam=beam//' '

      chtarg=TARGET//' '

      CALL pyinbm(chfram,chbeam,chtarg,win)

      IF(mint(65).EQ.1) goto 170


C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.

C...For e-gamma allow 2 alternatives.

      mint(121)=1

      mint(123)=mstp(14)

      IF(mstp(14).EQ.10.AND.(msel.EQ.1.OR.msel.EQ.2)) THEN

        IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.

     &  (iabs(mint(11)).GE.28.OR.iabs(mint(12)).GE.28)) mint(121)=3

        IF(mint(11).EQ.22.AND.mint(12).EQ.22) mint(121)=6

        IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.

     &  (iabs(mint(11)).EQ.11.OR.iabs(mint(12)).EQ.11)) mint(121)=2

      ENDIF


C...Set up kinematics of process.

      CALL pyinki(0)


C...Loop over gamma-p or gamma-gamma alternatives.

      DO 160 iga=1,mint(121)

        mint(122)=iga


C...Select partonic subprocesses to be included in the simulation.

        CALL pyinpr


C...Count number of subprocesses on.

        mint(48)=0

        DO 130 isub=1,500

          IF(mint(50).EQ.0.AND.isub.GE.91.AND.isub.LE.96.AND.

     &    msub(isub).EQ.1) THEN

            WRITE(mstu(11),5200) isub,chlh(mint(41)),chlh(mint(42))

            stop

          ELSEIF(msub(isub).EQ.1.AND.iset(isub).EQ.-1) THEN

            WRITE(mstu(11),5300) isub

            stop

          ELSEIF(msub(isub).EQ.1.AND.iset(isub).LE.-2) THEN

            WRITE(mstu(11),5400) isub

            stop

          ELSEIF(msub(isub).EQ.1) THEN

            mint(48)=mint(48)+1

          ENDIF

  130   CONTINUE

        IF(mint(48).EQ.0) THEN

          WRITE(mstu(11),5500)

          stop

        ENDIF

        mint(49)=mint(48)-msub(91)-msub(92)-msub(93)-msub(94)


C...Reset variables for cross-section calculation.

        DO 150 i=0,500

          DO 140 j=1,3

            ngen(i,j)=0

            xsec(i,j)=0d0

  140     CONTINUE

  150   CONTINUE


C...Find parametrized total cross-sections.

        CALL pyxtot


C...Maxima of differential cross-sections.

        IF(mstp(121).LE.1) CALL pymaxi


C...Initialize possibility of pileup events.

        IF(mint(121).GT.1) mstp(131)=0

        IF(mstp(131).NE.0) CALL pypile(1)


C...Initialize multiple interactions with variable impact parameter.

        IF(mint(50).EQ.1.AND.(mint(49).NE.0.OR.mstp(131).NE.0).AND.

     &  mstp(82).GE.2) CALL pymult(1)


C...Save results for gamma-p and gamma-gamma alternatives.

        IF(mint(121).GT.1) CALL pysave(1,iga)

  160 CONTINUE


C...Initialization finished.

  170 IF(mstp(122).GE.1) WRITE(mstu(11),5600)


C...Formats for initialization information.

 5100 FORMAT('1',18('*'),1x,'PYINIT: initialization of PYTHIA ',

     &'routines',1x,17('*'))

 5200 FORMAT(1x,'Error: process number ',i3,' not meaningful for ',a6,

     &'-',a6,' interactions.'/1x,'Execution stopped!')

 5300 FORMAT(1x,'Error: requested subprocess',i4,' not implemented.'/

     &1x,'Execution stopped!')

 5400 FORMAT(1x,'Error: requested subprocess',i4,' not existing.'/

     &1x,'Execution stopped!')

 5500 FORMAT(1x,'Error: no subprocess switched on.'/

     &1x,'Execution stopped.')

 5600 FORMAT(/1x,22('*'),1x,'PYINIT: initialization completed',1x,

     &22('*'))


      RETURN

      END


C*********************************************************************


C...PYEVNT

C...Administers the generation of a high-pT event via calls to

C...a number of subroutines.


      SUBROUTINE pyevnt


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/,

     &/pyint4/,/pyint5/,/pyuppr/

C...Local array.

      dimension vtx(4)


C...Initial values for some counters.

      n=0

      mint(5)=mint(5)+1

      mint(7)=0

      mint(8)=0

      mint(83)=0

      mint(84)=mstp(126)

      mstu(24)=0

      mstu70=0

      mstj14=mstj(14)


C...If variable energies: redo incoming kinematics and cross-section.

      msti(61)=0

      IF(mstp(171).EQ.1) THEN

        CALL pyinki(1)

        IF(msti(61).EQ.1) THEN

          mint(5)=mint(5)-1

          RETURN

        ENDIF

        IF(mint(121).GT.1) CALL pysave(3,1)

        CALL pyxtot

      ENDIF


C...Loop over number of pileup events; check space left.

      IF(mstp(131).LE.0) THEN

        npile=1

      ELSE

        CALL pypile(2)

        npile=mint(81)

      ENDIF

      DO 260 ipile=1,npile

        IF(mint(84)+100.GE.mstu(4)) THEN

          CALL pyerrm(11,

     &    '(PYEVNT:) no more space in PYJETS for pileup events')

          IF(mstu(21).GE.1) goto 270

        ENDIF

        mint(82)=ipile


C...Generate variables of hard scattering.

        mint(51)=0

        msti(52)=0

  100   CONTINUE

        IF(mint(51).NE.0.OR.mstu(24).NE.0) msti(52)=msti(52)+1

        mint(31)=0

        mint(51)=0

        mint(57)=0

        CALL pyrand

        IF(msti(61).EQ.1) THEN

          mint(5)=mint(5)-1

          RETURN

        ENDIF

        IF(mint(51).EQ.2) RETURN

        isub=mint(1)

        IF(mstp(111).EQ.-1) goto 250


        IF(isub.LE.90.OR.isub.GE.95) THEN

C...Hard scattering (including low-pT):

C...reconstruct kinematics and colour flow of hard scattering.

  110     mint(51)=0

          CALL pyscat

          IF(mint(51).EQ.1) goto 100

          ipu1=mint(84)+1

          ipu2=mint(84)+2

          IF(isub.EQ.95) goto 130


C...Showering of initial state partons (optional).

          alamsv=parj(81)

          parj(81)=parp(72)

          IF(mstp(61).GE.1.AND.mint(47).GE.2) CALL pysspa(ipu1,ipu2)

          parj(81)=alamsv

          IF(mint(51).EQ.1) goto 100


C...Showering of final state partons (optional).

          alamsv=parj(81)

          parj(81)=parp(72)

          IF(mstp(71).GE.1.AND.iset(isub).GE.2.AND.iset(isub).LE.10)

     &    THEN

            ipu3=mint(84)+3

            ipu4=mint(84)+4

            IF(iset(isub).EQ.5) ipu4=-3

            qmax=vint(55)

            IF(iset(isub).EQ.2) qmax=sqrt(parp(71))*vint(55)

            CALL pyshow(ipu3,ipu4,qmax)

          ELSEIF(mstp(71).GE.1.AND.iset(isub).EQ.11.AND.nfup.GE.1) THEN

            DO 120 iup=1,nfup

              ipu3=ifup(iup,1)+mint(84)

              ipu4=ifup(iup,2)+mint(84)

              qmax=sqrt(max(0d0,q2up(iup)))

              CALL pyshow(ipu3,ipu4,qmax)

  120       CONTINUE

          ENDIF

          parj(81)=alamsv


C...Decay of final state resonances.

          mint(32)=0

          IF(mstp(41).GE.1.AND.iset(isub).LE.10) CALL pyresd(0)

          IF(mint(51).EQ.1) goto 100

          mint(52)=n


C...Multiple interactions.

          IF(mstp(81).GE.1.AND.mint(50).EQ.1) CALL pymult(6)

          mint(53)=n


C...Hadron remnants and primordial kT.

  130     CALL pyremn(ipu1,ipu2)

          IF(mint(51).EQ.1.AND.mint(57).GE.1.AND.mint(57).LE.5) goto 110

          IF(mint(51).EQ.1) goto 100


        ELSE

C...Diffractive and elastic scattering.

          CALL pydiff

        ENDIF


C...Check that no odd resonance left undecayed.

        IF(mstp(111).GE.1) THEN

          nfix=n

          DO 140 i=mint(84)+1,nfix

            IF(k(i,1).GE.1.AND.k(i,1).LE.10.AND.k(i,2).NE.21.AND.

     &      k(i,2).NE.22) THEN

              IF(mwid(pycomp(k(i,2))).NE.0) THEN

                CALL pyresd(i)

                IF(mint(51).EQ.1) goto 100

              ENDIF

            ENDIF

  140     CONTINUE

        ENDIF


C...Recalculate energies from momenta and masses (if desired).

        IF(mstp(113).GE.1) THEN

          DO 150 i=mint(83)+1,n

            IF(k(i,1).GT.0.AND.k(i,1).LE.10) p(i,4)=sqrt(p(i,1)**2+

     &      p(i,2)**2+p(i,3)**2+p(i,5)**2)

  150     CONTINUE

          nrecal=n

        ENDIF


C...Rearrange partons along strings, check invariant mass cuts.

        mstu(28)=0

        IF(mstp(111).LE.0) mstj(14)=-1

        CALL pyprep(mint(84)+1)

        mstj(14)=mstj14

        IF(mstp(112).EQ.1.AND.mstu(28).EQ.3) goto 100

        IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) THEN

          DO 180 i=mint(84)+1,n

            IF(k(i,2).EQ.94) THEN

              DO 170 i1=i+1,min(n,i+3)

                IF(k(i1,3).EQ.i) THEN

                  k(i1,3)=mod(k(i1,4)/mstu(5),mstu(5))

                  IF(k(i1,3).EQ.0) THEN

                    DO 160 ii=mint(84)+1,i-1

                        IF(k(ii,2).EQ.k(i1,2)) THEN

                          IF(mod(k(ii,4),mstu(5)).EQ.i1.OR.

     &                    mod(k(ii,5),mstu(5)).EQ.i1) k(i1,3)=ii

                        ENDIF

  160               CONTINUE

                    IF(k(i+1,3).EQ.0) k(i+1,3)=k(i,3)

                  ENDIF

                ENDIF

  170         CONTINUE

            ENDIF

  180     CONTINUE

          CALL pyedit(12)

          CALL pyedit(14)

          IF(mstp(125).EQ.0) CALL pyedit(15)

          IF(mstp(125).EQ.0) mint(4)=0

          DO 200 i=mint(83)+1,n

            IF(k(i,1).EQ.11.AND.k(i,4).EQ.0.AND.k(i,5).EQ.0) THEN

              DO 190 i1=i+1,n

                IF(k(i1,3).EQ.i.AND.k(i,4).EQ.0) k(i,4)=i1

                IF(k(i1,3).EQ.i) k(i,5)=i1

  190         CONTINUE

            ENDIF

  200     CONTINUE

        ENDIF


C...Introduce separators between sections in PYLIST event listing.

        IF(ipile.EQ.1.AND.mstp(125).LE.0) THEN

          mstu70=1

          mstu(71)=n

        ELSEIF(ipile.EQ.1) THEN

          mstu70=3

          mstu(71)=2

          mstu(72)=mint(4)

          mstu(73)=n

        ENDIF


C...Go back to lab frame (needed for vertices, also in fragmentation).

        CALL pyfram(1)


C...Set nonvanishing production vertex (optional).

        IF(mstp(151).EQ.1) THEN

          DO 210 j=1,4

            vtx(j)=parp(150+j)*sqrt(-2d0*log(max(1d-10,pyr(0))))*

     &      sin(paru(2)*pyr(0))

  210     CONTINUE

          DO 230 i=mint(83)+1,n

            DO 220 j=1,4

              v(i,j)=v(i,j)+vtx(j)

  220       CONTINUE

  230     CONTINUE

        ENDIF


C...Perform hadronization (if desired).

        IF(mstp(111).GE.1) THEN

          CALL pyexec

          IF(mstu(24).NE.0) goto 100

        ENDIF

        IF(mstp(113).GE.1) THEN

          DO 240 i=nrecal,n

            IF(p(i,5).GT.0d0) p(i,4)=sqrt(p(i,1)**2+

     &      p(i,2)**2+p(i,3)**2+p(i,5)**2)

  240     CONTINUE

        ENDIF

        IF(mstp(125).EQ.0.OR.mstp(125).EQ.1) CALL pyedit(14)


C...Store event information and calculate Monte Carlo estimates of

C...subprocess cross-sections.

  250   IF(ipile.EQ.1) CALL pydocu


C...Set counters for current pileup event and loop to next one.

        msti(41)=ipile

        IF(ipile.GE.2.AND.ipile.LE.10) msti(40+ipile)=isub

        IF(mstu70.LT.10) THEN

          mstu70=mstu70+1

          mstu(70+mstu70)=n

        ENDIF

        mint(83)=n

        mint(84)=n+mstp(126)

        IF(ipile.LT.npile) CALL pyfram(2)

  260 CONTINUE


C...Generic information on pileup events. Reconstruct missing history.

      IF(mstp(131).EQ.1.AND.mstp(133).GE.1) THEN

        pari(91)=vint(132)

        pari(92)=vint(133)

        pari(93)=vint(134)

        IF(mstp(133).GE.2) pari(93)=pari(93)*xsec(0,3)/vint(131)

      ENDIF

      CALL pyedit(16)


C...Transform to the desired coordinate frame.

  270 CALL pyfram(mstp(124))

      mstu(70)=mstu70

      paru(21)=vint(1)


      RETURN

      END


C***********************************************************************


C...PYSTAT

C...Prints out information about cross-sections, decay widths, branching

C...ratios, kinematical limits, status codes and parameter values.


      SUBROUTINE pystat(MSTAT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint4/,/pyint5/,/pyint6/,/pymssm/

C...Local arrays, character variables and data.

      dimension wdtp(0:200),wdte(0:200,0:5)

      CHARACTER proga(6)*28,chau*16,chkf*16,chd1*16,chd2*16,chd3*16,

     &chin(2)*12,state(-1:5)*4,chkin(21)*18,disga(2)*28

      DATA proga/

     &'VMD/hadron * VMD            ','VMD/hadron * direct         ',

     &'VMD/hadron * anomalous      ','direct * direct             ',

     &'direct * anomalous          ','anomalous * anomalous       '/

      DATA disga/'e * VMD','e * anomalous'/

      DATA state/'----','off ','on  ','on/+','on/-','on/1','on/2'/,

     &chkin/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',

     &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',

     &'     y*_small     ','    eta*_large    ','    eta*_small    ',

     &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',

     &'       x_2        ','       x_F        ',' cos(theta_hard)  ',

     &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',

     &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',

     &'       tau''       '/


C...Cross-sections.

      IF(mstat.LE.1) THEN

        IF(mint(121).GT.1) CALL pysave(5,0)

        WRITE(mstu(11),5000)

        WRITE(mstu(11),5100)

        WRITE(mstu(11),5200) 0,proc(0),ngen(0,3),ngen(0,1),xsec(0,3)

        DO 100 i=1,500

          IF(msub(i).NE.1) goto 100

          WRITE(mstu(11),5200) i,proc(i),ngen(i,3),ngen(i,1),xsec(i,3)

  100   CONTINUE

        IF(mint(121).GT.1) THEN

          WRITE(mstu(11),5300)

          DO 110 iga=1,mint(121)

            CALL pysave(3,iga)

            IF(mint(121).EQ.2) THEN

              WRITE(mstu(11),5200) iga,disga(iga),ngen(0,3),ngen(0,1),

     &        xsec(0,3)

            ELSE

              WRITE(mstu(11),5200) iga,proga(iga),ngen(0,3),ngen(0,1),

     &        xsec(0,3)

            ENDIF

  110     CONTINUE

          CALL pysave(5,0)

        ENDIF

        WRITE(mstu(11),5400) 1d0-dble(ngen(0,3))/

     &  max(1d0,dble(ngen(0,2)))


C...Decay widths and branching ratios.

      ELSEIF(mstat.EQ.2) THEN

        WRITE(mstu(11),5500)

        WRITE(mstu(11),5600)

        DO 140 kc=1,500

          kf=kchg(kc,4)

          CALL pyname(kf,chkf)

          ioff=0

          IF(kc.LE.22) THEN

            IF(kc.GT.2*mstp(1).AND.kc.LE.10) goto 140

            IF(kc.GT.10+2*mstp(1).AND.kc.LE.20) goto 140

            IF(kc.LE.5.OR.(kc.GE.11.AND.kc.LE.16)) ioff=1

            IF(kc.EQ.18.AND.pmas(18,1).LT.1d0) ioff=1

            IF(kc.EQ.21.OR.kc.EQ.22) ioff=1

          ELSE

            IF(mwid(kc).LE.0) goto 140

            IF(imss(1).LE.0.AND.(kf/ksusy1.EQ.1.OR.

     &      kf/ksusy1.EQ.2)) goto 140

          ENDIF

C...Off-shell branchings.

          IF(ioff.EQ.1) THEN

            ngp=0

            IF(kc.LE.20) ngp=(mod(kc,10)+1)/2

            IF(ngp.LE.mstp(1)) WRITE(mstu(11),5700) kf,chkf(1:10),

     &      pmas(kc,1),0d0,0d0,state(mdcy(kc,1)),0d0

            DO 120 j=1,mdcy(kc,3)

              idc=j+mdcy(kc,2)-1

              ngp1=0

              IF(iabs(kfdp(idc,1)).LE.20) ngp1=

     &        (mod(iabs(kfdp(idc,1)),10)+1)/2

              ngp2=0

              IF(iabs(kfdp(idc,2)).LE.20) ngp2=

     &        (mod(iabs(kfdp(idc,2)),10)+1)/2

              CALL pyname(kfdp(idc,1),chd1)

              CALL pyname(kfdp(idc,2),chd2)

              IF(kfdp(idc,3).EQ.0) THEN

                IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.

     &          ngp2.LE.mstp(1)) WRITE(mstu(11),5800) idc,chd1(1:10),

     &          chd2(1:10),0d0,0d0,state(mdme(idc,1)),0d0

              ELSE

                CALL pyname(kfdp(idc,3),chd3)

                IF(mdme(idc,2).EQ.102.AND.ngp1.LE.mstp(1).AND.

     &          ngp2.LE.mstp(1)) WRITE(mstu(11),5850) idc,chd1(1:10),

     &          chd2(1:10),chd3(1:10),0d0,0d0,state(mdme(idc,1)),0d0

              ENDIF

  120       CONTINUE

C...On-shell decays.

          ELSE

            CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)

            brfin=1d0

            IF(wdte(0,0).LE.0d0) brfin=0d0

            WRITE(mstu(11),5700) kf,chkf(1:10),pmas(kc,1),wdtp(0),1d0,

     &      state(mdcy(kc,1)),brfin

            DO 130 j=1,mdcy(kc,3)

              idc=j+mdcy(kc,2)-1

              ngp1=0

              IF(iabs(kfdp(idc,1)).LE.20) ngp1=

     &        (mod(iabs(kfdp(idc,1)),10)+1)/2

              ngp2=0

              IF(iabs(kfdp(idc,2)).LE.20) ngp2=

     &        (mod(iabs(kfdp(idc,2)),10)+1)/2

              brfin=0d0

              IF(wdte(0,0).GT.0d0) brfin=wdte(j,0)/wdte(0,0)

              CALL pyname(kfdp(idc,1),chd1)

              CALL pyname(kfdp(idc,2),chd2)

              IF(kfdp(idc,3).EQ.0) THEN

                IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))

     &          WRITE(mstu(11),5800) idc,chd1(1:10),

     &          chd2(1:10),wdtp(j),wdtp(j)/wdtp(0),

     &          state(mdme(idc,1)),brfin

              ELSE

                CALL pyname(kfdp(idc,3),chd3)

                IF(ngp1.LE.mstp(1).AND.ngp2.LE.mstp(1))

     &          WRITE(mstu(11),5850) idc,chd1(1:10),

     &          chd2(1:10),chd3(1:10),wdtp(j),wdtp(j)/wdtp(0),

     &          state(mdme(idc,1)),brfin

              ENDIF

  130       CONTINUE

          ENDIF

  140   CONTINUE

        WRITE(mstu(11),5900)


C...Allowed incoming partons/particles at hard interaction.

      ELSEIF(mstat.EQ.3) THEN

        WRITE(mstu(11),6000)

        CALL pyname(mint(11),chau)

        chin(1)=chau(1:12)

        CALL pyname(mint(12),chau)

        chin(2)=chau(1:12)

        WRITE(mstu(11),6100) chin(1),chin(2)

        DO 150 i=-20,22

          IF(i.EQ.0) goto 150

          ia=iabs(i)

          IF(ia.GT.mstp(58).AND.ia.LE.10) goto 150

          IF(ia.GT.10+2*mstp(1).AND.ia.LE.20) goto 150

          CALL pyname(i,chau)

          WRITE(mstu(11),6200) chau,state(kfin(1,i)),chau,

     &    state(kfin(2,i))

  150   CONTINUE

        WRITE(mstu(11),6300)


C...User-defined limits on kinematical variables.

      ELSEIF(mstat.EQ.4) THEN

        WRITE(mstu(11),6400)

        WRITE(mstu(11),6500)

        shrmax=ckin(2)

        IF(shrmax.LT.0d0) shrmax=vint(1)

        WRITE(mstu(11),6600) ckin(1),chkin(1),shrmax

        pthmin=max(ckin(3),ckin(5))

        pthmax=ckin(4)

        IF(pthmax.LT.0d0) pthmax=0.5d0*shrmax

        WRITE(mstu(11),6700) ckin(3),pthmin,chkin(2),pthmax

        WRITE(mstu(11),6800) chkin(3),ckin(6)

        DO 160 i=4,14

          WRITE(mstu(11),6600) ckin(2*i-1),chkin(i),ckin(2*i)

  160   CONTINUE

        sprmax=ckin(32)

        IF(sprmax.LT.0d0) sprmax=vint(1)

        WRITE(mstu(11),6600) ckin(31),chkin(15),sprmax

        WRITE(mstu(11),6900)


C...Status codes and parameter values.

      ELSEIF(mstat.EQ.5) THEN

        WRITE(mstu(11),7000)

        WRITE(mstu(11),7100)

        DO 170 i=1,100

          WRITE(mstu(11),7200) i,mstp(i),parp(i),100+i,mstp(100+i),

     &    parp(100+i)

  170   CONTINUE


C...List of all processes implemented in the program.

      ELSEIF(mstat.EQ.6) THEN

        WRITE(mstu(11),7300)

        WRITE(mstu(11),7400)

        DO 180 i=1,500

          IF(iset(i).LT.0) goto 180

          WRITE(mstu(11),7500) i,proc(i),iset(i),kfpr(i,1),kfpr(i,2)

  180   CONTINUE

        WRITE(mstu(11),7600)

      ENDIF


C...Formats for printouts.

 5000 FORMAT('1',9('*'),1x,'PYSTAT:  Statistics on Number of ',

     &'Events and Cross-sections',1x,9('*'))

 5100 FORMAT(/1x,78('=')/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',12x,

     &'Subprocess',12x,'I',6x,'Number of points',6x,'I',4x,'Sigma',3x,

     &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',34('-'),'I',28('-'),

     &'I',4x,'(mb)',4x,'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,'I',1x,

     &'N:o',1x,'Type',25x,'I',4x,'Generated',9x,'Tried',1x,'I',12x,

     &'I'/1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/1x,'I',34x,'I',28x,

     &'I',12x,'I')

 5200 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i12,1x,i13,1x,'I',1x,1p,

     &d10.3,1x,'I')

 5300 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')/

     &1x,'I',34x,'I',28x,'I',12x,'I')

 5400 FORMAT(1x,'I',34x,'I',28x,'I',12x,'I'/1x,78('=')//

     &1x,'********* Fraction of events that fail fragmentation ',

     &'cuts =',1x,f8.5,' *********'/)

 5500 FORMAT('1',27('*'),1x,'PYSTAT:  Decay Widths and Branching ',

     &'Ratios',1x,27('*'))

 5600 FORMAT(/1x,98('=')/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/

     &1x,'I',5x,'Mother  -->  Branching/Decay Channel',8x,'I',1x,

     &'Width (GeV)',1x,'I',7x,'B.R.',1x,'I',1x,'Stat',1x,'I',2x,

     &'Eff. B.R.',1x,'I'/1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/

     &1x,98('='))

 5700 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,'I',1x,

     &i8,2x,a10,3x,'(m =',f10.3,')',2x,'-->',5x,'I',2x,1p,d10.3,0p,1x,

     &'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,1p,d10.3,0p,1x,'I')

 5800 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,15x,'I',2x,

     &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,

     &1p,d10.3,0p,1x,'I')

 5850 FORMAT(1x,'I',1x,i8,2x,a10,1x,'+',1x,a10,1x,'+',1x,a10,2x,'I',2x,

     &1p,d10.3,0p,1x,'I',1x,1p,d10.3,0p,1x,'I',1x,a4,1x,'I',1x,

     &1p,d10.3,0p,1x,'I')

 5900 FORMAT(1x,'I',49x,'I',13x,'I',12x,'I',6x,'I',12x,'I'/1x,98('='))

 6000 FORMAT('1',7('*'),1x,'PYSTAT: Allowed Incoming Partons/',

     &'Particles at Hard Interaction',1x,7('*'))

 6100 FORMAT(/1x,78('=')/1x,'I',38x,'I',37x,'I'/1x,'I',1x,

     &'Beam particle:',1x,a12,10x,'I',1x,'Target particle:',1x,a12,7x,

     &'I'/1x,'I',38x,'I',37x,'I'/1x,'I',1x,'Content',6x,'State',19x,

     &'I',1x,'Content',6x,'State',18x,'I'/1x,'I',38x,'I',37x,'I'/1x,

     &78('=')/1x,'I',38x,'I',37x,'I')

 6200 FORMAT(1x,'I',1x,a9,5x,a4,19x,'I',1x,a9,5x,a4,18x,'I')

 6300 FORMAT(1x,'I',38x,'I',37x,'I'/1x,78('='))

 6400 FORMAT('1',12('*'),1x,'PYSTAT: User-Defined Limits on ',

     &'Kinematical Variables',1x,12('*'))

 6500 FORMAT(/1x,78('=')/1x,'I',76x,'I')

 6600 FORMAT(1x,'I',16x,1p,d10.3,0p,1x,'<',1x,a,1x,'<',1x,1p,d10.3,0p,

     &16x,'I')

 6700 FORMAT(1x,'I',3x,1p,d10.3,0p,1x,'(',1p,d10.3,0p,')',1x,'<',1x,a,

     &1x,'<',1x,1p,d10.3,0p,16x,'I')

 6800 FORMAT(1x,'I',29x,a,1x,'=',1x,1p,d10.3,0p,16x,'I')

 6900 FORMAT(1x,'I',76x,'I'/1x,78('='))

 7000 FORMAT('1',12('*'),1x,'PYSTAT: Summary of Status Codes and ',

     &'Parameter Values',1x,12('*'))

 7100 FORMAT(/3x,'I',4x,'MSTP(I)',9x,'PARP(I)',20x,'I',4x,'MSTP(I)',9x,

     &'PARP(I)'/)

 7200 FORMAT(1x,i3,5x,i6,6x,1p,d10.3,0p,18x,i3,5x,i6,6x,1p,d10.3)

 7300 FORMAT('1',13('*'),1x,'PYSTAT: List of implemented processes',

     &1x,13('*'))

 7400 FORMAT(/1x,65('=')/1x,'I',34x,'I',28x,'I'/1x,'I',12x,

     &'Subprocess',12x,'I',1x,'ISET',2x,'KFPR(I,1)',2x,'KFPR(I,2)',1x,

     &'I'/1x,'I',34x,'I',28x,'I'/1x,65('=')/1x,'I',34x,'I',28x,'I')

 7500 FORMAT(1x,'I',1x,i3,1x,a28,1x,'I',1x,i4,1x,i10,1x,i10,1x,'I')

 7600 FORMAT(1x,'I',34x,'I',28x,'I'/1x,65('='))


      RETURN

      END


C*********************************************************************


C...PYINRE

C...Calculates full and effective widths of gauge bosons, stores

C...masses and widths, rescales coefficients to be used for

C...resonance production generation.


      SUBROUTINE pyinre


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/,/pyint4/,/pyint6/,/pymssm/

C...Local arrays and data.

      dimension wdtp(0:200),wdte(0:200,0:5),wdtpm(0:200),

     &wdtem(0:200,0:5),kcord(500),pmord(500)


C...Born level couplings in MSSM Higgs doublet sector.

      xw=paru(102)

      xwv=xw

      IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2

      xw1=1d0-xw

      IF(mstp(4).EQ.2) THEN

        tanbe=paru(141)

        ratbe=((1d0-tanbe**2)/(1d0+tanbe**2))**2

        sqmz=pmas(23,1)**2

        sqmw=pmas(24,1)**2

        sqmh=pmas(25,1)**2

        sqma=sqmh*(sqmz-sqmh)/(sqmz*ratbe-sqmh)

        sqmhp=0.5d0*(sqma+sqmz+sqrt((sqma+sqmz)**2-4d0*sqma*sqmz*ratbe))

        sqmhc=sqma+sqmw

        IF(sqmh.GE.sqmz.OR.min(sqma,sqmhp,sqmhc).LE.0d0) THEN

          WRITE(mstu(11),5000)

          stop

        ENDIF

        pmas(35,1)=sqrt(sqmhp)

        pmas(36,1)=sqrt(sqma)

        pmas(37,1)=sqrt(sqmhc)

        alsu=0.5d0*atan(2d0*tanbe*(sqma+sqmz)/((1d0-tanbe**2)*

     &  (sqma-sqmz)))

        besu=atan(tanbe)

        paru(142)=1d0

        paru(143)=1d0

        paru(161)=-sin(alsu)/cos(besu)

        paru(162)=cos(alsu)/sin(besu)

        paru(163)=paru(161)

        paru(164)=sin(besu-alsu)

        paru(165)=paru(164)

        paru(168)=sin(besu-alsu)+0.5d0*cos(2d0*besu)*sin(besu+alsu)/xw

        paru(171)=cos(alsu)/cos(besu)

        paru(172)=sin(alsu)/sin(besu)

        paru(173)=paru(171)

        paru(174)=cos(besu-alsu)

        paru(175)=paru(174)

        paru(176)=cos(2d0*alsu)*cos(besu+alsu)-2d0*sin(2d0*alsu)*

     &  sin(besu+alsu)

        paru(177)=cos(2d0*besu)*cos(besu+alsu)

        paru(178)=cos(besu-alsu)-0.5d0*cos(2d0*besu)*cos(besu+alsu)/xw

        paru(181)=tanbe

        paru(182)=1d0/tanbe

        paru(183)=paru(181)

        paru(184)=0d0

        paru(185)=paru(184)

        paru(186)=cos(besu-alsu)

        paru(187)=sin(besu-alsu)

        paru(188)=paru(186)

        paru(189)=paru(187)

        paru(190)=0d0

        paru(195)=cos(besu-alsu)

      ENDIF


C...Reset effective widths of gauge bosons.

      DO 110 i=1,500

        DO 100 j=1,5

          wids(i,j)=1d0

  100   CONTINUE

  110 CONTINUE


C...Order resonances by increasing mass (except Z0 and W+/-).

      nres=0

      DO 140 kc=1,500

        kf=kchg(kc,4)

        IF(kf.EQ.0) goto 140

        IF(mwid(kc).EQ.0) goto 140

        IF(kc.EQ.7.OR.kc.EQ.8.OR.kc.EQ.17.OR.kc.EQ.18) THEN

          IF(mstp(1).LE.3) goto 140

        ENDIF

        IF(kf/ksusy1.EQ.1.OR.kf/ksusy1.EQ.2) THEN

          IF(imss(1).LE.0) goto 140

        ENDIF

        nres=nres+1

        pmres=pmas(kc,1)

        IF(kc.EQ.23.OR.kc.EQ.24) pmres=0d0

        DO 120 i1=nres-1,1,-1

          IF(pmres.GE.pmord(i1)) goto 130

          kcord(i1+1)=kcord(i1)

          pmord(i1+1)=pmord(i1)

  120   CONTINUE

  130   kcord(i1+1)=kc

        pmord(i1+1)=pmres

  140 CONTINUE


C...Loop over possible resonances.

      DO 180 i=1,nres

        kc=kcord(i)

        kf=kchg(kc,4)


C...Check that no fourth generation channels on by mistake.

        IF(mstp(1).LE.3) THEN

          DO 150 j=1,mdcy(kc,3)

            idc=j+mdcy(kc,2)-1

            kfa1=iabs(kfdp(idc,1))

            kfa2=iabs(kfdp(idc,2))

            IF(kfa1.EQ.7.OR.kfa1.EQ.8.OR.kfa1.EQ.17.OR.kfa1.EQ.18.OR.

     &      kfa2.EQ.7.OR.kfa2.EQ.8.OR.kfa2.EQ.17.OR.kfa2.EQ.18)

     &      mdme(idc,1)=-1

  150     CONTINUE

        ENDIF


C...Check that no supersymmetric channels on by mistake.

        IF(imss(1).LE.0) THEN

          DO 160 j=1,mdcy(kc,3)

            idc=j+mdcy(kc,2)-1

            kfa1s=iabs(kfdp(idc,1))/ksusy1

            kfa2s=iabs(kfdp(idc,2))/ksusy1

            IF(kfa1s.EQ.1.OR.kfa1s.EQ.2.OR.kfa2s.EQ.1.OR.kfa2s.EQ.2)

     &      mdme(idc,1)=-1

  160     CONTINUE

        ENDIF


C...Find mass and evaluate width.

        pmr=pmas(kc,1)

        IF(kf.EQ.25.OR.kf.EQ.35.OR.kf.EQ.36) mint(62)=1

        IF(mwid(kc).EQ.3) mint(63)=1

        CALL pywidt(kf,pmr**2,wdtp,wdte)

        mint(51)=0


C...Evaluate suppression factors due to non-simulated channels.

        IF(kchg(kc,3).EQ.0) THEN

          wids(kc,1)=((wdte(0,1)+wdte(0,2))**2+

     &    2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+

     &    2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2

          wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)

          wids(kc,3)=0d0

          wids(kc,4)=0d0

          wids(kc,5)=0d0

        ELSE

          IF(mwid(kc).EQ.3) mint(63)=1

          CALL pywidt(-kf,pmr**2,wdtpm,wdtem)

          mint(51)=0

          wids(kc,1)=((wdte(0,1)+wdte(0,2))*(wdtem(0,1)+wdtem(0,3))+

     &    (wdte(0,1)+wdte(0,2))*(wdtem(0,4)+wdtem(0,5))+

     &    (wdte(0,4)+wdte(0,5))*(wdtem(0,1)+wdtem(0,3))+

     &    wdte(0,4)*wdtem(0,5)+wdte(0,5)*wdtem(0,4))/wdtp(0)**2

          wids(kc,2)=(wdte(0,1)+wdte(0,2)+wdte(0,4))/wdtp(0)

          wids(kc,3)=(wdtem(0,1)+wdtem(0,3)+wdtem(0,4))/wdtp(0)

          wids(kc,4)=((wdte(0,1)+wdte(0,2))**2+

     &    2d0*(wdte(0,1)+wdte(0,2))*(wdte(0,4)+wdte(0,5))+

     &    2d0*wdte(0,4)*wdte(0,5))/wdtp(0)**2

          wids(kc,5)=((wdtem(0,1)+wdtem(0,3))**2+

     &    2d0*(wdtem(0,1)+wdtem(0,3))*(wdtem(0,4)+wdtem(0,5))+

     &    2d0*wdtem(0,4)*wdtem(0,5))/wdtp(0)**2

        ENDIF


C...Set resonance widths and branching ratios;

C...also on/off switch for decays.

        IF(mwid(kc).EQ.1.OR.mwid(kc).EQ.3) THEN

          pmas(kc,2)=wdtp(0)

          pmas(kc,3)=min(0.9d0*pmas(kc,1),10d0*pmas(kc,2))

          mdcy(kc,1)=mstp(41)

          DO 170 j=1,mdcy(kc,3)

            idc=j+mdcy(kc,2)-1

            brat(idc)=0d0

            IF(wdtp(0).GT.0d0) brat(idc)=wdtp(j)/wdtp(0)

  170     CONTINUE

        ENDIF

  180 CONTINUE


C...Flavours of leptoquark: redefine charge and name.

      kflqq=kfdp(mdcy(39,2),1)

      kflql=kfdp(mdcy(39,2),2)

      kchg(39,1)=kchg(pycomp(kflqq),1)*isign(1,kflqq)+

     &kchg(pycomp(kflql),1)*isign(1,kflql)

      ll=1

      IF(iabs(kflql).EQ.13) ll=2

      IF(iabs(kflql).EQ.15) ll=3

      chaf(39,1)='LQ_'//chaf(iabs(kflqq),1)(1:1)//

     &chaf(iabs(kflql),1)(1:ll)//' '

      chaf(39,2)=chaf(39,2)(1:4+ll)//'bar '


C...Special cases in treatment of gamma*/Z0: redefine process name.

      IF(mstp(43).EQ.1) THEN

        proc(1)='f + fbar -> gamma*'

        proc(15)='f + fbar -> g + gamma*'

        proc(19)='f + fbar -> gamma + gamma*'

        proc(30)='f + g -> f + gamma*'

        proc(35)='f + gamma -> f + gamma*'

      ELSEIF(mstp(43).EQ.2) THEN

        proc(1)='f + fbar -> Z0'

        proc(15)='f + fbar -> g + Z0'

        proc(19)='f + fbar -> gamma + Z0'

        proc(30)='f + g -> f + Z0'

        proc(35)='f + gamma -> f + Z0'

      ELSEIF(mstp(43).EQ.3) THEN

        proc(1)='f + fbar -> gamma*/Z0'

        proc(15)='f + fbar -> g + gamma*/Z0'

        proc(19)='f + fbar -> gamma + gamma*/Z0'

        proc(30)='f + g -> f + gamma*/Z0'

        proc(35)='f + gamma -> f + gamma*/Z0'

      ENDIF


C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.

      IF(mstp(44).EQ.1) THEN

        proc(141)='f + fbar -> gamma*'

      ELSEIF(mstp(44).EQ.2) THEN

        proc(141)='f + fbar -> Z0'

      ELSEIF(mstp(44).EQ.3) THEN

        proc(141)='f + fbar -> Z''0'

      ELSEIF(mstp(44).EQ.4) THEN

        proc(141)='f + fbar -> gamma*/Z0'

      ELSEIF(mstp(44).EQ.5) THEN

        proc(141)='f + fbar -> gamma*/Z''0'

      ELSEIF(mstp(44).EQ.6) THEN

        proc(141)='f + fbar -> Z0/Z''0'

      ELSEIF(mstp(44).EQ.7) THEN

        proc(141)='f + fbar -> gamma*/Z0/Z''0'

      ENDIF


C...Special cases in treatment of WW -> WW: redefine process name.

      IF(mstp(45).EQ.1) THEN

        proc(77)='W+ + W+ -> W+ + W+'

      ELSEIF(mstp(45).EQ.2) THEN

        proc(77)='W+ + W- -> W+ + W-'

      ELSEIF(mstp(45).EQ.3) THEN

        proc(77)='W+/- + W+/- -> W+/- + W+/-'

      ENDIF


C...Format for error information.

 5000 FORMAT(1x,'Error: unphysical input tan^2(beta) and m_H ',

     &'combination'/1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYINBM

C...Identifies the two incoming particles and the choice of frame.


       SUBROUTINE pyinbm(CHFRAM,CHBEAM,CHTARG,WIN)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/

C...Local arrays, character variables and data.

      CHARACTER chfram*8,chbeam*8,chtarg*8,chcom(3)*8,chalp(2)*26,

     &chidnt(3)*8,chtemp*8,chcde(29)*8,chinit*76

      dimension len(3),kcde(29),pm(2)

      DATA chalp/'abcdefghijklmnopqrstuvwxyz',

     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/

      DATA chcde/'e-      ','e+      ','nu_e    ','nu_ebar ',

     &'mu-     ','mu+     ','nu_mu   ','nu_mubar','tau-    ',

     &'tau+    ','nu_tau  ','nu_tauba','pi+     ','pi-     ',

     &'n0      ','nbar0   ','p+      ','pbar-   ','gamma   ',

     &'lambda0 ','sigma-  ','sigma0  ','sigma+  ','xi-     ',

     &'xi0     ','omega-  ','pi0     ','reggeon ','pomeron '/

      DATA kcde/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,

     &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,

     &3312,3322,3334,111,28,29/


C...Store initial energy. Default frame.

      vint(290)=win

      mint(111)=0


C...Convert character variables to lowercase and find their length.

      chcom(1)=chfram

      chcom(2)=chbeam

      chcom(3)=chtarg

      DO 130 i=1,3

        len(i)=8

        DO 110 ll=8,1,-1

          IF(len(i).EQ.ll.AND.chcom(i)(ll:ll).EQ.' ') len(i)=ll-1

          DO 100 la=1,26

            IF(chcom(i)(ll:ll).EQ.chalp(2)(la:la)) chcom(i)(ll:ll)=

     &      chalp(1)(la:la)

  100     CONTINUE

  110   CONTINUE

        chidnt(i)=chcom(i)


C...Fix up bar, underscore and charge in particle name (if needed).

        DO 120 ll=1,6

          IF(chidnt(i)(ll:ll).EQ.'~') THEN

            chtemp=chidnt(i)

            chidnt(i)=chtemp(1:ll-1)//'bar'//chtemp(ll+1:6)//'  '

          ENDIF

  120   CONTINUE

        IF(chidnt(i)(7:7).EQ.'~') chidnt(i)(7:8)='ba'

        IF(chidnt(i)(1:2).EQ.'nu'.AND.chidnt(i)(3:3).NE.'_') THEN

          chtemp=chidnt(i)

          chidnt(i)='nu_'//chtemp(3:7)

        ELSEIF(chidnt(i)(1:2).EQ.'n ') THEN

          chidnt(i)(1:3)='n0 '

        ELSEIF(chidnt(i)(1:4).EQ.'nbar') THEN

          chidnt(i)(1:5)='nbar0'

        ELSEIF(chidnt(i)(1:2).EQ.'p ') THEN

          chidnt(i)(1:3)='p+ '

        ELSEIF(chidnt(i)(1:4).EQ.'pbar'.OR.

     &    chidnt(i)(1:2).EQ.'p-') THEN

          chidnt(i)(1:5)='pbar-'

        ELSEIF(chidnt(i)(1:6).EQ.'lambda') THEN

          chidnt(i)(7:7)='0'

        ELSEIF(chidnt(i)(1:3).EQ.'reg') THEN

          chidnt(i)(1:7)='reggeon'

        ELSEIF(chidnt(i)(1:3).EQ.'pom') THEN

          chidnt(i)(1:7)='pomeron'

        ENDIF

  130 CONTINUE


C...Identify free initialization.

      IF(chcom(1)(1:2).EQ.'no') THEN

        mint(65)=1

        RETURN

      ENDIF


C...Identify incoming beam and target particles.

      DO 150 i=1,2

        DO 140 j=1,29

          IF(chidnt(i+1).EQ.chcde(j)) mint(10+i)=kcde(j)

  140   CONTINUE

        pm(i)=pymass(mint(10+i))

        vint(2+i)=pm(i)

  150 CONTINUE

      IF(mint(11).EQ.0) WRITE(mstu(11),5000) chbeam(1:len(2))

      IF(mint(12).EQ.0) WRITE(mstu(11),5100) chtarg(1:len(3))

      IF(mint(11).EQ.0.OR.mint(12).EQ.0) stop


C...Identify choice of frame and input energies.

      chinit=' '


C...Events defined in the CM frame.

      IF(chcom(1)(1:2).EQ.'cm') THEN

        mint(111)=1

        s=win**2

        IF(mstp(122).GE.1) THEN

          IF(chcom(2)(1:1).NE.'e') THEN

            loffs=(31-(len(2)+len(3)))/2

            chinit(loffs+1:76)='PYTHIA will be initialized for a '//

     &      chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &      ' collider'//' '

          ELSE

            loffs=(30-(len(2)+len(3)))/2

            chinit(loffs+1:76)='PYTHIA will be initialized for an '//

     &      chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &      ' collider'//' '

          ENDIF

          WRITE(mstu(11),5200) chinit

          WRITE(mstu(11),5300) win

        ENDIF


C...Events defined in fixed target frame.

      ELSEIF(chcom(1)(1:3).EQ.'fix') THEN

        mint(111)=2

        s=pm(1)**2+pm(2)**2+2d0*pm(2)*sqrt(pm(1)**2+win**2)

        IF(mstp(122).GE.1) THEN

          loffs=(29-(len(2)+len(3)))/2

          chinit(loffs+1:76)='PYTHIA will be initialized for '//

     &    chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &    ' fixed target'//' '

          WRITE(mstu(11),5200) chinit

          WRITE(mstu(11),5400) win

          WRITE(mstu(11),5500) sqrt(s)

        ENDIF


C...Frame defined by user three-vectors.

      ELSEIF(chcom(1)(1:3).EQ.'use') THEN

        mint(111)=3

        p(1,5)=pm(1)

        p(2,5)=pm(2)

        p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)

        p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)

        s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-

     &  (p(1,3)+p(2,3))**2

        IF(mstp(122).GE.1) THEN

          loffs=(12-(len(2)+len(3)))/2

          chinit(loffs+1:76)='PYTHIA will be initialized for '//

     &    chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &    ' user-specified configuration'//' '

          WRITE(mstu(11),5200) chinit

          WRITE(mstu(11),5600)

          WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)

          WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)

          WRITE(mstu(11),5500) sqrt(max(0d0,s))

        ENDIF


C...Frame defined by user four-vectors.

      ELSEIF(chcom(1)(1:4).EQ.'four') THEN

        mint(111)=4

        pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2

        p(1,5)=sign(sqrt(abs(pms1)),pms1)

        pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2

        p(2,5)=sign(sqrt(abs(pms2)),pms2)

        s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-

     &  (p(1,3)+p(2,3))**2

        IF(mstp(122).GE.1) THEN

          loffs=(12-(len(2)+len(3)))/2

          chinit(loffs+1:76)='PYTHIA will be initialized for '//

     &    chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &    ' user-specified configuration'//' '

          WRITE(mstu(11),5200) chinit

          WRITE(mstu(11),5600)

          WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)

          WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)

          WRITE(mstu(11),5500) sqrt(max(0d0,s))

        ENDIF


C...Frame defined by user five-vectors.

      ELSEIF(chcom(1)(1:4).EQ.'five') THEN

        mint(111)=5

        s=(p(1,4)+p(2,4))**2-(p(1,1)+p(2,1))**2-(p(1,2)+p(2,2))**2-

     &  (p(1,3)+p(2,3))**2

        IF(mstp(122).GE.1) THEN

          loffs=(12-(len(2)+len(3)))/2

          chinit(loffs+1:76)='PYTHIA will be initialized for '//

     &    chcom(2)(1:len(2))//' on '//chcom(3)(1:len(3))//

     &    ' user-specified configuration'//' '

          WRITE(mstu(11),5200) chinit

          WRITE(mstu(11),5600)

          WRITE(mstu(11),5700) chcom(2),p(1,1),p(1,2),p(1,3),p(1,4)

          WRITE(mstu(11),5700) chcom(3),p(2,1),p(2,2),p(2,3),p(2,4)

          WRITE(mstu(11),5500) sqrt(max(0d0,s))

        ENDIF


C...Unknown frame. Error for too low CM energy.

      ELSE

        WRITE(mstu(11),5800) chfram(1:len(1))

        stop

      ENDIF

      IF(s.LT.parp(2)**2) THEN

        WRITE(mstu(11),5900) sqrt(s)

        stop

      ENDIF


C...Formats for initialization and error information.

 5000 FORMAT(1x,'Error: unrecognized beam particle ''',a,'''D0'/

     &1x,'Execution stopped!')

 5100 FORMAT(1x,'Error: unrecognized target particle ''',a,'''D0'/

     &1x,'Execution stopped!')

 5200 FORMAT(/1x,78('=')/1x,'I',76x,'I'/1x,'I',a76,'I')

 5300 FORMAT(1x,'I',18x,'at',1x,f10.3,1x,'GeV center-of-mass energy',

     &19x,'I'/1x,'I',76x,'I'/1x,78('='))

 5400 FORMAT(1x,'I',22x,'at',1x,f10.3,1x,'GeV/c lab-momentum',22x,'I')

 5500 FORMAT(1x,'I',76x,'I'/1x,'I',11x,'corresponding to',1x,f10.3,1x,

     &'GeV center-of-mass energy',12x,'I'/1x,'I',76x,'I'/1x,78('='))

 5600 FORMAT(1x,'I',76x,'I'/1x,'I',18x,'px (GeV/c)',3x,'py (GeV/c)',3x,

     &'pz (GeV/c)',6x,'E (GeV)',9x,'I')

 5700 FORMAT(1x,'I',8x,a8,4(2x,f10.3,1x),8x,'I')

 5800 FORMAT(1x,'Error: unrecognized coordinate frame ''',a,'''D0'/

     &1x,'Execution stopped!')

 5900 FORMAT(1x,'Error: too low CM energy,',f8.3,' GeV for event ',

     &'generation.'/1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYINKI

C...Sets up kinematics, including rotations and boosts to/from CM frame.


      SUBROUTINE pyinki(MODKI)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/


C...Set initial flavour state.

      n=2

      DO 100 i=1,2

        k(i,1)=1

        k(i,2)=mint(10+i)

  100 CONTINUE


C...Reset boost. Do kinematics for various cases.

      DO 110 j=6,10

        vint(j)=0d0

  110 CONTINUE


C...Set up kinematics for events defined in CM frame.

      IF(mint(111).EQ.1) THEN

        win=vint(290)

        IF(modki.EQ.1) win=parp(171)*vint(290)

        s=win**2

        p(1,5)=vint(3)

        p(2,5)=vint(4)

        p(1,1)=0d0

        p(1,2)=0d0

        p(2,1)=0d0

        p(2,2)=0d0

        p(1,3)=sqrt(((s-p(1,5)**2-p(2,5)**2)**2-(2d0*p(1,5)*p(2,5))**2)/

     &  (4d0*s))

        p(2,3)=-p(1,3)

        p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)

        p(2,4)=sqrt(p(2,3)**2+p(2,5)**2)


C...Set up kinematics for fixed target events.

      ELSEIF(mint(111).EQ.2) THEN

        win=vint(290)

        IF(modki.EQ.1) win=parp(171)*vint(290)

        p(1,5)=vint(3)

        p(2,5)=vint(4)

        p(1,1)=0d0

        p(1,2)=0d0

        p(2,1)=0d0

        p(2,2)=0d0

        p(1,3)=win

        p(1,4)=sqrt(p(1,3)**2+p(1,5)**2)

        p(2,3)=0d0

        p(2,4)=p(2,5)

        s=p(1,5)**2+p(2,5)**2+2d0*p(2,4)*p(1,4)

        vint(10)=p(1,3)/(p(1,4)+p(2,4))

        CALL pyrobo(0,0,0d0,0d0,0d0,0d0,-vint(10))


C...Set up kinematics for events in user-defined frame.

      ELSEIF(mint(111).EQ.3) THEN

        p(1,5)=vint(3)

        p(2,5)=vint(4)

        p(1,4)=sqrt(p(1,1)**2+p(1,2)**2+p(1,3)**2+p(1,5)**2)

        p(2,4)=sqrt(p(2,1)**2+p(2,2)**2+p(2,3)**2+p(2,5)**2)

        DO 120 j=1,3

          vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))

  120   CONTINUE

        CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))

        vint(7)=pyangl(p(1,1),p(1,2))

        CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)

        vint(6)=pyangl(p(1,3),p(1,1))

        CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)

        s=p(1,5)**2+p(2,5)**2+2d0*(p(1,4)*p(2,4)-p(1,3)*p(2,3))


C...Set up kinematics for events with user-defined four-vectors.

      ELSEIF(mint(111).EQ.4) THEN

        pms1=p(1,4)**2-p(1,1)**2-p(1,2)**2-p(1,3)**2

        p(1,5)=sign(sqrt(abs(pms1)),pms1)

        pms2=p(2,4)**2-p(2,1)**2-p(2,2)**2-p(2,3)**2

        p(2,5)=sign(sqrt(abs(pms2)),pms2)

        DO 130 j=1,3

          vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))

  130   CONTINUE

        CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))

        vint(7)=pyangl(p(1,1),p(1,2))

        CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)

        vint(6)=pyangl(p(1,3),p(1,1))

        CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)

        s=(p(1,4)+p(2,4))**2


C...Set up kinematics for events with user-defined five-vectors.

      ELSEIF(mint(111).EQ.5) THEN

        DO 140 j=1,3

          vint(7+j)=(p(1,j)+p(2,j))/(p(1,4)+p(2,4))

  140   CONTINUE

        CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))

        vint(7)=pyangl(p(1,1),p(1,2))

        CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)

        vint(6)=pyangl(p(1,3),p(1,1))

        CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)

        s=(p(1,4)+p(2,4))**2

      ENDIF


C...Return or error for too low CM energy.

      IF(modki.EQ.1.AND.s.LT.parp(2)**2) THEN

        IF(mstp(172).LE.1) THEN

          CALL pyerrm(23,

     &    '(PYINKI:) too low invariant mass in this event')

        ELSE

          msti(61)=1

          RETURN

        ENDIF

      ENDIF


C...Save information on incoming particles.

      vint(1)=sqrt(s)

      vint(2)=s

      IF(mint(111).GE.4) vint(3)=p(1,5)

      IF(mint(111).GE.4) vint(4)=p(2,5)

      vint(5)=p(1,3)

      IF(modki.EQ.0) vint(289)=s

      DO 150 j=1,5

        v(1,j)=0d0

        v(2,j)=0d0

        vint(290+j)=p(1,j)

        vint(295+j)=p(2,j)

  150 CONTINUE


C...Store pT cut-off and related constants to be used in generation.

      IF(modki.EQ.0) vint(285)=ckin(3)

      IF(mstp(82).LE.1) THEN

        IF(mint(121).GT.1) parp(81)=1.30d0+0.15d0*log(vint(1)/200d0)/

     &  log(900d0/200d0)

        ptmn=parp(81)

      ELSE

        IF(mint(121).GT.1) parp(82)=1.25d0+0.15d0*log(vint(1)/200d0)/

     &  log(900d0/200d0)

        ptmn=parp(82)

      ENDIF

      vint(149)=4d0*ptmn**2/s


      RETURN

      END


C*********************************************************************


C...PYINPR

C...Selects partonic subprocesses to be included in the simulation.


      SUBROUTINE pyinpr


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pydat1/,/pydat3/,/pysubs/,/pypars/,/pyint1/,/pyint2/


C...Reset processes to be included.

      IF(msel.NE.0) THEN

        DO 100 i=1,500

          msub(i)=0

  100   CONTINUE

      ENDIF


C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous.

      IF(mint(121).EQ.2) THEN

        msub(10)=1

        mint(123)=mint(122)+1


C...For gamma-p or gamma-gamma with MSTP(14)=10 allow mixture.

C...Here also set a few parameters otherwise normally not touched.

      ELSEIF(mint(121).GT.1) THEN


C...Parton distributions dampened at small Q2; go to low energies,

C...alpha_s <1; no minimum pT cut-off a priori.

        mstp(57)=3

        mstp(85)=0

        parp(2)=2d0

        paru(115)=1d0

        ckin(5)=0.2d0

        ckin(6)=0.2d0


C...Define pT cut-off parameters and whether run involves low-pT.

        IF(mstp(82).LE.1) THEN

          ptmvmd=1.30d0+0.15d0*log(vint(1)/200d0)/log(900d0/200d0)

        ELSE

          ptmvmd=1.25d0+0.15d0*log(vint(1)/200d0)/log(900d0/200d0)

        ENDIF

        ptmdir=parp(15)

        ptmano=ptmvmd

        IF(mstp(15).EQ.5) ptmano=0.60d0+

     &  0.125d0*log(1d0+0.10d0*vint(1))**2

        iptl=1

        IF(vint(285).GT.max(ptmvmd,ptmdir,ptmano)) iptl=0

        IF(msel.EQ.2) iptl=1


C...Set up for p/VMD * VMD.

        IF(mint(122).EQ.1) THEN

          mint(123)=2

          msub(11)=1

          msub(12)=1

          msub(13)=1

          msub(28)=1

          msub(53)=1

          msub(68)=1

          IF(iptl.EQ.1) msub(95)=1

          IF(msel.EQ.2) THEN

            msub(91)=1

            msub(92)=1

            msub(93)=1

            msub(94)=1

          ENDIF

          parp(81)=ptmvmd

          parp(82)=ptmvmd

          IF(iptl.EQ.1) ckin(3)=0d0


C...Set up for p/VMD * direct gamma.

        ELSEIF(mint(122).EQ.2) THEN

          mint(123)=0

          IF(mint(121).EQ.6) mint(123)=5

          msub(33)=1

          msub(54)=1

          IF(iptl.EQ.1) ckin(3)=ptmdir


C...Set up for p/VMD * anomalous gamma.

        ELSEIF(mint(122).EQ.3) THEN

          mint(123)=3

          IF(mint(121).EQ.6) mint(123)=7

          msub(11)=1

          msub(12)=1

          msub(13)=1

          msub(28)=1

          msub(53)=1

          msub(68)=1

          IF(mstp(82).GE.2) mstp(85)=1

          IF(iptl.EQ.1) ckin(3)=ptmano


C...Set up for direct * direct gamma (switch off leptons).

        ELSEIF(mint(122).EQ.4) THEN

          mint(123)=0

          msub(58)=1

          DO 110 ii=mdcy(22,2),mdcy(22,2)+mdcy(22,3)-1

            IF(iabs(kfdp(ii,1)).GE.10) mdme(ii,1)=min(0,mdme(ii,1))

  110     CONTINUE

          IF(iptl.EQ.1) ckin(3)=ptmdir


C...Set up for direct * anomalous gamma.

        ELSEIF(mint(122).EQ.5) THEN

          mint(123)=6

          msub(33)=1

          msub(54)=1

          IF(iptl.EQ.1) ckin(3)=ptmano


C...Set up for anomalous * anomalous gamma.

        ELSEIF(mint(122).EQ.6) THEN

          mint(123)=3

          msub(11)=1

          msub(12)=1

          msub(13)=1

          msub(28)=1

          msub(53)=1

          msub(68)=1

          IF(mstp(82).GE.2) mstp(85)=1

          IF(iptl.EQ.1) ckin(3)=ptmano

        ENDIF


C...End of special set up for gamma-p and gamma-gamma.

        ckin(1)=2d0*ckin(3)

      ENDIF


C...Flavour information for individual beams.

      DO 120 i=1,2

        mint(40+i)=1

        IF(mint(123).GE.1.AND.mint(10+i).EQ.22) mint(40+i)=2

        IF(iabs(mint(10+i)).GT.100) mint(40+i)=2

        IF(mint(10+i).EQ.28.OR.mint(10+i).EQ.29) mint(40+i)=2

        mint(44+i)=mint(40+i)

        IF(mstp(11).GE.1.AND.iabs(mint(10+i)).EQ.11) mint(44+i)=3

  120 CONTINUE


C...If two gammas, whereof one direct, pick the first.

      IF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN

        IF(mint(123).GE.4.AND.mint(123).LE.6) THEN

          mint(41)=1

          mint(45)=1

        ENDIF

      ELSEIF(mint(11).EQ.22.OR.mint(12).EQ.22) THEN

        IF(mint(123).GE.4) CALL pyerrm(26,

     &  '(PYINPR:) unallowed MSTP(14) code for single photon')

      ENDIF


C...Flavour information on combination of incoming particles.

      mint(43)=2*mint(41)+mint(42)-2

      mint(44)=mint(43)

      IF(mint(123).LE.0) THEN

        IF(mint(11).EQ.22) mint(43)=mint(43)+2

        IF(mint(12).EQ.22) mint(43)=mint(43)+1

      ELSEIF(mint(123).LE.3) THEN

        IF(mint(11).EQ.22) mint(44)=mint(44)-2

        IF(mint(12).EQ.22) mint(44)=mint(44)-1

      ELSEIF(mint(11).EQ.22.AND.mint(12).EQ.22) THEN

        mint(43)=4

        mint(44)=1

      ENDIF

      mint(47)=2*min(2,mint(45))+min(2,mint(46))-2

      IF(min(mint(45),mint(46)).EQ.3) mint(47)=5

      mint(50)=0

      IF(mint(41).EQ.2.AND.mint(42).EQ.2) mint(50)=1

      IF((mint(11).EQ.22.OR.mint(12).EQ.22).AND.mint(123).GE.3)

     &mint(50)=0

      mint(107)=0

      IF(mint(11).EQ.22) THEN

        mint(107)=mint(123)

        IF(mint(123).GE.4) mint(107)=0

        IF(mint(123).EQ.7) mint(107)=2

      ENDIF

      mint(108)=0

      IF(mint(12).EQ.22) THEN

        mint(108)=mint(123)

        IF(mint(123).GE.4) mint(108)=mint(123)-3

        IF(mint(123).EQ.7) mint(108)=3

      ENDIF


C...Select default processes according to incoming beams

C...(already done for gamma-p and gamma-gamma with MSTP(14)=10).

      IF(mint(121).GT.1) THEN

      ELSEIF(msel.EQ.1.OR.msel.EQ.2) THEN


        IF(mint(43).EQ.1) THEN

C...Lepton + lepton -> gamma/Z0 or W.

          IF(mint(11)+mint(12).EQ.0) msub(1)=1

          IF(mint(11)+mint(12).NE.0) msub(2)=1


        ELSEIF(mint(43).LE.3.AND.mint(123).EQ.0.AND.

     &    (mint(11).EQ.22.OR.mint(12).EQ.22)) THEN

C...Unresolved photon + lepton: Compton scattering.

          msub(34)=1


        ELSEIF(mint(43).LE.3) THEN

C...Lepton + hadron: deep inelastic scattering.

          msub(10)=1


        ELSEIF(mint(123).EQ.0.AND.mint(11).EQ.22.AND.

     &    mint(12).EQ.22) THEN

C...Two unresolved photons: fermion pair production.

          msub(58)=1


        ELSEIF((mint(123).EQ.0.AND.(mint(11).EQ.22.OR.mint(12).EQ.22))

     &    .OR.(mint(123).GE.4.AND.mint(123).LE.6.AND.mint(11).EQ.22.AND.

     &    mint(12).EQ.22)) THEN

C...Unresolved photon + hadron: photon-parton scattering.

          msub(33)=1

          msub(34)=1

          msub(54)=1


        ELSEIF(msel.EQ.1) THEN

C...High-pT QCD processes:

          msub(11)=1

          msub(12)=1

          msub(13)=1

          msub(28)=1

          msub(53)=1

          msub(68)=1

          IF(mstp(82).LE.1.AND.ckin(3).LT.parp(81)) msub(95)=1

          IF(mstp(82).GE.2.AND.ckin(3).LT.parp(82)) msub(95)=1

          IF(msub(95).EQ.1.AND.mint(50).EQ.0) msub(95)=0


        ELSE

C...All QCD processes:

          msub(11)=1

          msub(12)=1

          msub(13)=1

          msub(28)=1

          msub(53)=1

          msub(68)=1

          msub(91)=1

          msub(92)=1

          msub(93)=1

          msub(94)=1

          msub(95)=1

        ENDIF


      ELSEIF(msel.GE.4.AND.msel.LE.8) THEN

C...Heavy quark production.

        msub(81)=1

        msub(82)=1

        msub(84)=1

        DO 130 j=1,min(8,mdcy(21,3))

          mdme(mdcy(21,2)+j-1,1)=0

  130   CONTINUE

        mdme(mdcy(21,2)+msel-1,1)=1

        msub(85)=1

        DO 140 j=1,min(12,mdcy(22,3))

          mdme(mdcy(22,2)+j-1,1)=0

  140   CONTINUE

        mdme(mdcy(22,2)+msel-1,1)=1


      ELSEIF(msel.EQ.10) THEN

C...Prompt photon production:

        msub(14)=1

        msub(18)=1

        msub(29)=1


      ELSEIF(msel.EQ.11) THEN

C...Z0/gamma* production:

        msub(1)=1


      ELSEIF(msel.EQ.12) THEN

C...W+/- production:

        msub(2)=1


      ELSEIF(msel.EQ.13) THEN

C...Z0 + jet:

        msub(15)=1

        msub(30)=1


      ELSEIF(msel.EQ.14) THEN

C...W+/- + jet:

        msub(16)=1

        msub(31)=1


      ELSEIF(msel.EQ.15) THEN

C...Z0 & W+/- pair production:

        msub(19)=1

        msub(20)=1

        msub(22)=1

        msub(23)=1

        msub(25)=1


      ELSEIF(msel.EQ.16) THEN

C...h0 production:

        msub(3)=1

        msub(102)=1

        msub(103)=1

        msub(123)=1

        msub(124)=1


      ELSEIF(msel.EQ.17) THEN

C...h0 & Z0 or W+/- pair production:

        msub(24)=1

        msub(26)=1


      ELSEIF(msel.EQ.18) THEN

C...h0 production; interesting processes in e+e-.

        msub(24)=1

        msub(103)=1

        msub(123)=1

        msub(124)=1


      ELSEIF(msel.EQ.19) THEN

C...h0, H0 and A0 production; interesting processes in e+e-.

        msub(24)=1

        msub(103)=1

        msub(123)=1

        msub(124)=1

        msub(153)=1

        msub(171)=1

        msub(173)=1

        msub(174)=1

        msub(158)=1

        msub(176)=1

        msub(178)=1

        msub(179)=1


      ELSEIF(msel.EQ.21) THEN

C...Z'0 production:

        msub(141)=1


      ELSEIF(msel.EQ.22) THEN

C...W'+/- production:

        msub(142)=1


      ELSEIF(msel.EQ.23) THEN

C...H+/- production:

        msub(143)=1


      ELSEIF(msel.EQ.24) THEN

C...R production:

        msub(144)=1


      ELSEIF(msel.EQ.25) THEN

C...LQ (leptoquark) production.

        msub(145)=1

        msub(162)=1

        msub(163)=1

        msub(164)=1


      ELSEIF(msel.GE.35.AND.msel.LE.38) THEN

C...Production of one heavy quark (W exchange):

        msub(83)=1

        DO 150 j=1,min(8,mdcy(21,3))

          mdme(mdcy(21,2)+j-1,1)=0

  150   CONTINUE

        mdme(mdcy(21,2)+msel-31,1)=1


CMRENNA++Define SUSY alternatives.

      ELSEIF(msel.EQ.39) THEN

C...Turn on all SUSY processes.

        IF(mint(43).EQ.4) THEN

C...Hadron-hadron processes.

          DO 160 i=201,280

            IF(iset(i).GE.0) msub(i)=1

  160     CONTINUE

        ELSEIF(mint(43).EQ.1) THEN

C...Lepton-lepton processes: QED production of squarks.

          DO 170 i=201,214

            msub(i)=1

  170     CONTINUE

          msub(210)=0

          msub(211)=0

          msub(212)=0

          DO 180 i=216,228

            msub(i)=1

  180     CONTINUE

          DO 190 i=261,263

            msub(i)=1

  190     CONTINUE

          msub(277)=1

          msub(278)=1

        ENDIF


      ELSEIF(msel.EQ.40) THEN

C...Gluinos and squarks.

        IF(mint(43).EQ.4) THEN

          msub(243)=1

          msub(244)=1

          msub(258)=1

          msub(259)=1

          msub(261)=1

          msub(262)=1

          msub(264)=1

          msub(265)=1

          DO 200 i=271,280

            msub(i)=1

  200     CONTINUE

        ELSEIF(mint(43).EQ.1) THEN

          msub(277)=1

          msub(278)=1

        ENDIF


      ELSEIF(msel.EQ.41) THEN

C...Stop production.

        msub(261)=1

        msub(262)=1

        msub(263)=1

        IF(mint(43).EQ.4) THEN

          msub(264)=1

          msub(265)=1

        ENDIF


      ELSEIF(msel.EQ.42) THEN

C...Slepton production.

        DO 210 i=201,214

          msub(i)=1

  210   CONTINUE

        IF(mint(43).NE.4) THEN

          msub(210)=0

          msub(211)=0

          msub(212)=0

        ENDIF


      ELSEIF(msel.EQ.43) THEN

C...Neutralino/Chargino + Gluino/Squark.

        IF(mint(43).EQ.4) THEN

          DO 220 i=237,242

            msub(i)=1

  220     CONTINUE

          DO 230 i=246,257

            msub(i)=1

  230     CONTINUE

        ENDIF


      ELSEIF(msel.EQ.44) THEN

C...Neutralino/Chargino pair production.

        IF(mint(43).EQ.4) THEN

          DO 240 i=216,236

            msub(i)=1

  240     CONTINUE

        ELSEIF(mint(43).EQ.1) THEN

          DO 250 i=216,228

            msub(i)=1

  250     CONTINUE

        ENDIF

      ENDIF


C...Find heaviest new quark flavour allowed in processes 81-84.

      kflqm=1

      DO 260 i=1,min(8,mdcy(21,3))

        idc=i+mdcy(21,2)-1

        IF(mdme(idc,1).LE.0) goto 260

        kflqm=i

  260 CONTINUE

      IF(mstp(7).GE.1.AND.mstp(7).LE.8.AND.(msel.LE.3.OR.msel.GE.9))

     &kflqm=mstp(7)

      mint(55)=kflqm

      kfpr(81,1)=kflqm

      kfpr(81,2)=kflqm

      kfpr(82,1)=kflqm

      kfpr(82,2)=kflqm

      kfpr(83,1)=kflqm

      kfpr(84,1)=kflqm

      kfpr(84,2)=kflqm


C...Find heaviest new fermion flavour allowed in process 85.

      kflfm=1

      DO 270 i=1,min(12,mdcy(22,3))

        idc=i+mdcy(22,2)-1

        IF(mdme(idc,1).LE.0) goto 270

        kflfm=kfdp(idc,1)

  270 CONTINUE

      IF(((mstp(7).GE.1.AND.mstp(7).LE.8).OR.(mstp(7).GE.11.AND.

     &mstp(7).LE.18)).AND.(msel.LE.3.OR.msel.GE.9)) kflfm=mstp(7)

      mint(56)=kflfm

      kfpr(85,1)=kflfm

      kfpr(85,2)=kflfm


      RETURN

      END


C*********************************************************************


C...PYXTOT

C...Parametrizes total, elastic and diffractive cross-sections

C...for different energies and beams. Donnachie-Landshoff for

C...total and Schuler-Sjostrand for elastic and diffractive.

C...Process code IPROC:

C...=  1 : p + p;

C...=  2 : pbar + p;

C...=  3 : pi+ + p;

C...=  4 : pi- + p;

C...=  5 : pi0 + p;

C...=  6 : phi + p;

C...=  7 : J/psi + p;

C...= 11 : rho + rho;

C...= 12 : rho + phi;

C...= 13 : rho + J/psi;

C...= 14 : phi + phi;

C...= 15 : phi + J/psi;

C...= 16 : J/psi + J/psi;

C...= 21 : gamma + p (DL);

C...= 22 : gamma + p (VDM).

C...= 23 : gamma + pi (DL);

C...= 24 : gamma + pi (VDM);

C...= 25 : gamma + gamma (DL);

C...= 26 : gamma + gamma (VDM).


      SUBROUTINE pyxtot


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint7/sigt(0:6,0:6,0:5)

      SAVE /pydat1/,/pypars/,/pyint1/,/pyint5/,/pyint7/

C...Local arrays.

      dimension nproc(30),xpar(30),ypar(30),ihada(20),ihadb(20),

     &pmhad(4),bhad(4),betp(4),ifitsd(20),ifitdd(20),ceffs(10,8),

     &ceffd(10,9),sigtmp(6,0:5)


C...Common constants.

      DATA eps/0.0808d0/, eta/-0.4525d0/, alp/0.25d0/, cres/2d0/,

     &pmrc/1.062d0/, smp/0.880d0/, facel/0.0511d0/, facsd/0.0336d0/,

     &facdd/0.0084d0/


C...Number of multiple processes to be evaluated (= 0 : undefined).

      DATA nproc/7*1,3*0,6*1,4*0,4*3,2*6,4*0/

C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).

      DATA xpar/2*21.70d0,3*13.63d0,10.01d0,0.970d0,3*0d0,

     &8.56d0,6.29d0,0.609d0,4.62d0,0.447d0,0.0434d0,4*0d0,

     &0.0677d0,0.0534d0,0.0425d0,0.0335d0,2.11d-4,1.31d-4,4*0d0/

      DATA ypar/

     &56.08d0,98.39d0,27.56d0,36.02d0,31.79d0,-1.51d0,-0.146d0,3*0d0,

     &13.08d0,-0.62d0,-0.060d0,0.030d0,-0.0028d0,0.00028d0,4*0d0,

     &0.129d0,0.115d0,0.081d0,0.072d0,2.15d-4,1.70d-4,4*0d0/


C...Beam and target hadron class:

C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.

      DATA ihada/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/

      DATA ihadb/7*1,3*0,2,3,4,3,2*4,4*0/

C...Characteristic class masses, slope parameters, beta = sqrt(X).

      DATA pmhad/0.938d0,0.770d0,1.020d0,3.097d0/

      DATA bhad/2.3d0,1.4d0,1.4d0,0.23d0/

      DATA betp/4.658d0,2.926d0,2.149d0,0.208d0/


C...Fitting constants used in parametrizations of diffractive results.

      DATA ifitsd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/

      DATA ifitdd/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/

      DATA ((ceffs(j1,j2),j2=1,8),j1=1,10)/

     &0.213d0, 0.0d0, -0.47d0, 150d0, 0.213d0, 0.0d0, -0.47d0, 150d0,

     &0.213d0, 0.0d0, -0.47d0, 150d0, 0.267d0, 0.0d0, -0.47d0, 100d0,

     &0.213d0, 0.0d0, -0.47d0, 150d0, 0.232d0, 0.0d0, -0.47d0, 110d0,

     &0.213d0, 7.0d0, -0.55d0, 800d0, 0.115d0, 0.0d0, -0.47d0, 110d0,

     &0.267d0, 0.0d0, -0.46d0,  75d0, 0.267d0, 0.0d0, -0.46d0,  75d0,

     &0.232d0, 0.0d0, -0.46d0,  85d0, 0.267d0, 0.0d0, -0.48d0, 100d0,

     &0.115d0, 0.0d0, -0.50d0,  90d0, 0.267d0, 6.0d0, -0.56d0, 420d0,

     &0.232d0, 0.0d0, -0.48d0, 110d0, 0.232d0, 0.0d0, -0.48d0, 110d0,

     &0.115d0, 0.0d0, -0.52d0, 120d0, 0.232d0, 6.0d0, -0.56d0, 470d0,

     &0.115d0, 5.5d0, -0.58d0, 570d0, 0.115d0, 5.5d0, -0.58d0, 570d0/

      DATA ((ceffd(j1,j2),j2=1,9),j1=1,10)/

     &3.11d0, -7.34d0,  9.71d0, 0.068d0, -0.42d0,  1.31d0,

     &-1.37d0,  35.0d0,  118d0,  3.11d0, -7.10d0,  10.6d0,

     &0.073d0, -0.41d0, 1.17d0, -1.41d0,  31.6d0,   95d0,

     &3.12d0, -7.43d0,  9.21d0, 0.067d0, -0.44d0,  1.41d0,

     &-1.35d0,  36.5d0,  132d0,  3.13d0, -8.18d0, -4.20d0,

     &0.056d0, -0.71d0, 3.12d0, -1.12d0,  55.2d0, 1298d0,

     &3.11d0, -6.90d0,  11.4d0, 0.078d0, -0.40d0,  1.05d0,

     &-1.40d0,  28.4d0,   78d0,  3.11d0, -7.13d0,  10.0d0,

     &0.071d0, -0.41d0, 1.23d0, -1.34d0,  33.1d0,  105d0,

     &3.12d0, -7.90d0, -1.49d0, 0.054d0, -0.64d0,  2.72d0,

     &-1.13d0,  53.1d0,  995d0,  3.11d0, -7.39d0,  8.22d0,

     &0.065d0, -0.44d0, 1.45d0, -1.36d0,  38.1d0,  148d0,

     &3.18d0, -8.95d0, -3.37d0, 0.057d0, -0.76d0,  3.32d0,

     &-1.12d0,  55.6d0, 1472d0,  4.18d0, -29.2d0,  56.2d0,

     &0.074d0, -1.36d0, 6.67d0, -1.14d0, 116.2d0, 6532d0/


C...Parameters. Combinations of the energy.

      aem=paru(101)

      pmth=parp(102)

      s=vint(2)

      srt=vint(1)

      seps=s**eps

      seta=s**eta

      slog=log(s)


C...Ratio of gamma/pi (for rescaling in parton distributions).

      vint(281)=(xpar(22)*seps+ypar(22)*seta)/

     &(xpar(5)*seps+ypar(5)*seta)

      IF(mint(50).NE.1) RETURN


C...Order flavours of incoming particles: KF1 < KF2.

      IF(iabs(mint(11)).LE.iabs(mint(12))) THEN

        kf1=iabs(mint(11))

        kf2=iabs(mint(12))

        iord=1

      ELSE

        kf1=iabs(mint(12))

        kf2=iabs(mint(11))

        iord=2

      ENDIF

      isgn12=isign(1,mint(11)*mint(12))


C...Find process number (for lookup tables).

      IF(kf1.GT.1000) THEN

        iproc=1

        IF(isgn12.LT.0) iproc=2

      ELSEIF(kf1.GT.100.AND.kf2.GT.1000) THEN

        iproc=3

        IF(isgn12.LT.0) iproc=4

        IF(kf1.EQ.111) iproc=5

      ELSEIF(kf1.GT.100) THEN

        iproc=11

      ELSEIF(kf2.GT.1000) THEN

        iproc=21

        IF(mint(123).EQ.2) iproc=22

      ELSEIF(kf2.GT.100) THEN

        iproc=23

        IF(mint(123).EQ.2) iproc=24

      ELSE

        iproc=25

        IF(mint(123).EQ.2) iproc=26

      ENDIF


C... Number of multiple processes to be stored; beam/target side.

      npr=nproc(iproc)

      mint(101)=1

      mint(102)=1

      IF(npr.EQ.3) THEN

        mint(100+iord)=4

      ELSEIF(npr.EQ.6) THEN

        mint(101)=4

        mint(102)=4

      ENDIF

      n1=0

      IF(mint(101).EQ.4) n1=4

      n2=0

      IF(mint(102).EQ.4) n2=4


C...Do not do any more for user-set or undefined cross-sections.

      IF(mstp(31).LE.0) RETURN

      IF(npr.EQ.0) CALL pyerrm(26,

     &'(PYXTOT:) cross section for this process not yet implemented')


C...Parameters. Combinations of the energy.

      aem=paru(101)

      pmth=parp(102)

      s=vint(2)

      srt=vint(1)

      seps=s**eps

      seta=s**eta

      slog=log(s)


C...Loop over multiple processes (for VDM).

      DO 110 i=1,npr

        IF(npr.EQ.1) THEN

          ipr=iproc

        ELSEIF(npr.EQ.3) THEN

          ipr=i+4

          IF(kf2.LT.1000) ipr=i+10

        ELSEIF(npr.EQ.6) THEN

          ipr=i+10

        ENDIF


C...Evaluate hadron species, mass, slope contribution and fit number.

        iha=ihada(ipr)

        ihb=ihadb(ipr)

        pma=pmhad(iha)

        pmb=pmhad(ihb)

        bha=bhad(iha)

        bhb=bhad(ihb)

        isd=ifitsd(ipr)

        idd=ifitdd(ipr)


C...Skip if energy too low relative to masses.

        DO 100 j=0,5

          sigtmp(i,j)=0d0

  100   CONTINUE

        IF(srt.LT.pma+pmb+parp(104)) goto 110


C...Total cross-section. Elastic slope parameter and cross-section.

        sigtmp(i,0)=xpar(ipr)*seps+ypar(ipr)*seta

        bel=2d0*bha+2d0*bhb+4d0*seps-4.2d0

        sigtmp(i,1)=facel*sigtmp(i,0)**2/bel


C...Diffractive scattering A + B -> X + B.

        bsd=2d0*bhb

        sqml=(pma+pmth)**2

        sqmu=s*ceffs(isd,1)+ceffs(isd,2)

        sum1=log((bsd+2d0*alp*log(s/sqml))/

     &  (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)

        bxb=ceffs(isd,3)+ceffs(isd,4)/s

        sum2=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)/

     &  (bsd+2d0*alp*log(s/((pma+pmth)*(pma+pmrc)))+bxb)

        sigtmp(i,2)=facsd*xpar(ipr)*betp(ihb)*max(0d0,sum1+sum2)


C...Diffractive scattering A + B -> A + X.

        bsd=2d0*bha

        sqml=(pmb+pmth)**2

        sqmu=s*ceffs(isd,5)+ceffs(isd,6)

        sum1=log((bsd+2d0*alp*log(s/sqml))/

     &  (bsd+2d0*alp*log(s/sqmu)))/(2d0*alp)

        bax=ceffs(isd,7)+ceffs(isd,8)/s

        sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/

     &  (bsd+2d0*alp*log(s/((pmb+pmth)*(pmb+pmrc)))+bax)

        sigtmp(i,3)=facsd*xpar(ipr)*betp(iha)*max(0d0,sum1+sum2)


C...Order single diffractive correctly.

        IF(iord.EQ.2) THEN

          sigsav=sigtmp(i,2)

          sigtmp(i,2)=sigtmp(i,3)

          sigtmp(i,3)=sigsav

        ENDIF


C...Double diffractive scattering A + B -> X1 + X2.

        yeff=log(s*smp/((pma+pmth)*(pmb+pmth))**2)

        deff=ceffd(idd,1)+ceffd(idd,2)/slog+ceffd(idd,3)/slog**2

        sum1=deff+yeff*(log(max(1d-10,yeff/deff))-1d0)/(2d0*alp)

        IF(yeff.LE.0) sum1=0d0

        sqmu=s*(ceffd(idd,4)+ceffd(idd,5)/slog+ceffd(idd,6)/slog**2)

        slup=log(max(1.1d0,s/(alp*(pma+pmth)**2*(pmb+pmth)*(pmb+pmrc))))

        sldn=log(max(1.1d0,s/(alp*sqmu*(pmb+pmth)*(pmb+pmrc))))

        sum2=cres*log(1d0+((pmb+pmrc)/(pmb+pmth))**2)*log(slup/sldn)/

     &  (2d0*alp)

        slup=log(max(1.1d0,s/(alp*(pmb+pmth)**2*(pma+pmth)*(pma+pmrc))))

        sldn=log(max(1.1d0,s/(alp*sqmu*(pma+pmth)*(pma+pmrc))))

        sum3=cres*log(1d0+((pma+pmrc)/(pma+pmth))**2)*log(slup/sldn)/

     &  (2d0*alp)

        bxx=ceffd(idd,7)+ceffd(idd,8)/srt+ceffd(idd,9)/s

        slrr=log(s/(alp*(pma+pmth)*(pma+pmrc)*(pmb+pmth)*(pmb*pmrc)))

        sum4=cres**2*log(1d0+((pma+pmrc)/(pma+pmth))**2)*

     &  log(1d0+((pmb+pmrc)/(pmb+pmth))**2)/max(0.1d0,2d0*alp*slrr+bxx)

        sigtmp(i,4)=facdd*xpar(ipr)*max(0d0,sum1+sum2+sum3+sum4)


C...Non-diffractive by unitarity.

        sigtmp(i,5)=sigtmp(i,0)-sigtmp(i,1)-sigtmp(i,2)-sigtmp(i,3)-

     &  sigtmp(i,4)

  110 CONTINUE


C...Put temporary results in output array: only one process.

      IF(mint(101).EQ.1.AND.mint(102).EQ.1) THEN

        DO 120 j=0,5

          sigt(0,0,j)=sigtmp(1,j)

  120   CONTINUE


C...Beam multiple processes.

      ELSEIF(mint(101).EQ.4.AND.mint(102).EQ.1) THEN

        DO 140 i=1,4

          conv=aem/parp(160+i)

          i1=max(1,i-1)

          DO 130 j=0,5

            sigt(i,0,j)=conv*sigtmp(i1,j)

  130     CONTINUE

  140   CONTINUE

        DO 150 j=0,5

          sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)

  150   CONTINUE


C...Target multiple processes.

      ELSEIF(mint(101).EQ.1.AND.mint(102).EQ.4) THEN

        DO 170 i=1,4

          conv=aem/parp(160+i)

          iv=max(1,i-1)

          DO 160 j=0,5

            sigt(0,i,j)=conv*sigtmp(iv,j)

  160     CONTINUE

  170   CONTINUE

        DO 180 j=0,5

          sigt(0,0,j)=sigt(0,1,j)+sigt(0,2,j)+sigt(0,3,j)+sigt(0,4,j)

  180   CONTINUE


C...Both beam and target multiple processes.

      ELSE

        DO 210 i1=1,4

          DO 200 i2=1,4

            conv=aem**2/(parp(160+i1)*parp(160+i2))

            IF(i1.LE.2) THEN

              iv=max(1,i2-1)

            ELSEIF(i2.LE.2) THEN

              iv=max(1,i1-1)

            ELSEIF(i1.EQ.i2) THEN

              iv=2*i1-2

            ELSE

              iv=5

            ENDIF

            DO 190 j=0,5

              jv=j

              IF(i2.GT.i1.AND.(j.EQ.2.OR.j.EQ.3)) jv=5-j

              sigt(i1,i2,j)=conv*sigtmp(iv,jv)

  190       CONTINUE

  200     CONTINUE

  210   CONTINUE

        DO 230 j=0,5

          DO 220 i=1,4

            sigt(i,0,j)=sigt(i,1,j)+sigt(i,2,j)+sigt(i,3,j)+sigt(i,4,j)

            sigt(0,i,j)=sigt(1,i,j)+sigt(2,i,j)+sigt(3,i,j)+sigt(4,i,j)

  220     CONTINUE

          sigt(0,0,j)=sigt(1,0,j)+sigt(2,0,j)+sigt(3,0,j)+sigt(4,0,j)

  230   CONTINUE

      ENDIF


C...Scale up uniformly for Donnachie-Landshoff parametrization.

      IF(iproc.EQ.21.OR.iproc.EQ.23.OR.iproc.EQ.25) THEN

        rfac=(xpar(iproc)*seps+ypar(iproc)*seta)/sigt(0,0,0)

        DO 260 i1=0,n1

          DO 250 i2=0,n2

            DO 240 j=0,5

              sigt(i1,i2,j)=rfac*sigt(i1,i2,j)

  240       CONTINUE

  250     CONTINUE

  260   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYMAXI

C...Finds optimal set of coefficients for kinematical variable selection

C...and the maximum of the part of the differential cross-section used

C...in the event weighting.


      SUBROUTINE pymaxi


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      common/pyint7/sigt(0:6,0:6,0:5)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint6/,/pyint7/

C...Local arrays, character variables and data.

      CHARACTER cvar(4)*4

      dimension npts(4),mvarpt(500,4),vintpt(500,30),sigspt(500),

     &narel(7),wtrel(7),wtmat(7,7),wtreln(7),coefu(7),coefo(7),

     &iaccmx(4),sigsmx(4),sigssm(3),pmmn(2)

      DATA cvar/'tau ','tau''','y*  ','cth '/

      DATA sigssm/3*0d0/


C...Select subprocess to study: skip cases not applicable.

      nposi=0

      vint(143)=1d0

      vint(144)=1d0

      xsec(0,1)=0d0

      DO 460 isub=1,500

        mint(51)=0

        IF(iset(isub).EQ.11) THEN

          xsec(isub,1)=1.00001d0*coef(isub,1)

          nposi=nposi+1

          goto 450

        ELSEIF(isub.GE.91.AND.isub.LE.95) THEN

          xsec(isub,1)=sigt(0,0,isub-90)

          IF(msub(isub).NE.1) goto 460

          nposi=nposi+1

          goto 450

        ELSEIF(isub.EQ.96) THEN

          IF(mint(50).EQ.0) goto 460

          IF(msub(95).NE.1.AND.mstp(81).LE.0.AND.mstp(131).LE.0)

     &    goto 460

          IF(mint(49).EQ.0.AND.mstp(131).EQ.0) goto 460

        ELSEIF(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13.OR.isub.EQ.28.OR.

     &    isub.EQ.53.OR.isub.EQ.68) THEN

          IF(msub(isub).NE.1.OR.msub(95).EQ.1) goto 460

        ELSE

          IF(msub(isub).NE.1) goto 460

        ENDIF

        mint(1)=isub

        istsb=iset(isub)

        IF(isub.EQ.96) istsb=2

        IF(mstp(122).GE.2) WRITE(mstu(11),5000) isub

        mwtxs=0

        IF(mstp(142).GE.1.AND.isub.NE.96.AND.msub(91)+msub(92)+msub(93)+

     &  msub(94)+msub(95).EQ.0) mwtxs=1


C...Find resonances (explicit or implicit in cross-section).

        mint(72)=0

        kfr1=0

        IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN

          kfr1=kfpr(isub,1)

        ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165

     &    .OR.isub.EQ.171.OR.isub.EQ.176) THEN

          kfr1=23

        ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172

     &    .OR.isub.EQ.177) THEN

          kfr1=24

        ELSEIF(isub.GE.71.AND.isub.LE.77) THEN

          kfr1=25

          IF(mstp(46).EQ.5) THEN

            kfr1=30

            pmas(30,1)=parp(45)

            pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)

          ENDIF

        ELSEIF(isub.EQ.194) THEN

          kfr1=54

        ENDIF

        ckmx=ckin(2)

        IF(ckmx.LE.0d0) ckmx=vint(1)

        kcr1=pycomp(kfr1)

        IF(kfr1.NE.0) THEN

          IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.

     &    ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0

        ENDIF

        IF(kfr1.NE.0) THEN

          taur1=pmas(kcr1,1)**2/vint(2)

          gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)

          mint(72)=1

          mint(73)=kfr1

          vint(73)=taur1

          vint(74)=gamr1

        ENDIF

        kfr2=0

        IF(isub.EQ.141.OR.isub.EQ.194) THEN

          kfr2=23

          IF(isub.EQ.194) kfr2=56

          kcr2=pycomp(kfr2)

          taur2=pmas(kcr2,1)**2/vint(2)

          gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)

          IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.

     &    ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0

          IF(kfr2.NE.0.AND.kfr1.NE.0) THEN

            mint(72)=2

            mint(74)=kfr2

            vint(75)=taur2

            vint(76)=gamr2

          ELSEIF(kfr2.NE.0) THEN

            kfr1=kfr2

            taur1=taur2

            gamr1=gamr2

            mint(72)=1

            mint(73)=kfr1

            vint(73)=taur1

            vint(74)=gamr1

            kfr2=0

          ENDIF

        ENDIF


C...Find product masses and minimum pT of process.

        sqm3=0d0

        sqm4=0d0

        mint(71)=0

        vint(71)=ckin(3)

        vint(80)=1d0

        IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

          nbw=0

          DO 110 i=1,2

            pmmn(i)=0d0

            IF(kfpr(isub,i).EQ.0) THEN

            ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.

     &        parp(41)) THEN

              IF(i.EQ.1) sqm3=pmas(pycomp(kfpr(isub,i)),1)**2

              IF(i.EQ.2) sqm4=pmas(pycomp(kfpr(isub,i)),1)**2

            ELSE

              nbw=nbw+1

C...This prevents SUSY/t particles from becoming too light.

              kflw=kfpr(isub,i)

              IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN

                kcw=pycomp(kflw)

                pmmn(i)=pmas(kcw,1)

                DO 100 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1

                  IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN

                    pmsum=pmas(pycomp(kfdp(idc,1)),1)+

     &              pmas(pycomp(kfdp(idc,2)),1)

                    IF(kfdp(idc,3).NE.0) pmsum=pmsum+

     &              pmas(pycomp(kfdp(idc,3)),1)

                    pmmn(i)=min(pmmn(i),pmsum)

                  ENDIF

  100           CONTINUE

              ELSEIF(kflw.EQ.6) THEN

                pmmn(i)=pmas(24,1)+pmas(5,1)

              ENDIF

            ENDIF

  110     CONTINUE

          IF(nbw.GE.1) THEN

            ckin41=ckin(41)

            ckin43=ckin(43)

            ckin(41)=max(pmmn(1),ckin(41))

            ckin(43)=max(pmmn(2),ckin(43))

            CALL pyofsh(3,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)

            ckin(41)=ckin41

            ckin(43)=ckin43

            IF(mint(51).EQ.1) THEN

              WRITE(mstu(11),5100) isub

              msub(isub)=0

              goto 460

            ENDIF

            sqm3=pqm3**2

            sqm4=pqm4**2

          ENDIF

          IF(min(sqm3,sqm4).LT.ckin(6)**2) mint(71)=1

          IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))

          IF(isub.EQ.96.AND.mstp(82).LE.1) vint(71)=parp(81)

          IF(isub.EQ.96.AND.mstp(82).GE.2) vint(71)=0.08d0*parp(82)

        ENDIF

        vint(63)=sqm3

        vint(64)=sqm4


C...Prepare for additional variable choices in 2 -> 3.

        IF(istsb.EQ.5) THEN

          vint(201)=0d0

          IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)

          vint(206)=vint(201)

          vint(204)=pmas(23,1)

          IF(isub.EQ.124) vint(204)=pmas(24,1)

          IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182

     &    .OR.isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)

          vint(209)=vint(204)

        ENDIF


C...Number of points for each variable: tau, tau', y*, cos(theta-hat).

        npts(1)=2+2*mint(72)

        IF(mint(47).EQ.1) THEN

          IF(istsb.EQ.1.OR.istsb.EQ.2) npts(1)=1

        ELSEIF(mint(47).EQ.5) THEN

          IF(istsb.LE.2.OR.istsb.GT.5) npts(1)=npts(1)+1

        ENDIF

        npts(2)=1

        IF(istsb.GE.3.AND.istsb.LE.5) THEN

          IF(mint(47).GE.2) npts(2)=2

          IF(mint(47).EQ.5) npts(2)=3

        ENDIF

        npts(3)=1

        IF(mint(47).GE.4) npts(3)=3

        IF(mint(45).EQ.3) npts(3)=npts(3)+1

        IF(mint(46).EQ.3) npts(3)=npts(3)+1

        npts(4)=1

        IF(istsb.EQ.2.OR.istsb.EQ.4) npts(4)=5

        ntry=npts(1)*npts(2)*npts(3)*npts(4)


C...Reset coefficients of cross-section weighting.

        DO 120 j=1,20

          coef(isub,j)=0d0

  120   CONTINUE

        coef(isub,1)=1d0

        coef(isub,8)=0.5d0

        coef(isub,9)=0.5d0

        coef(isub,13)=1d0

        coef(isub,18)=1d0

        mcth=0

        mtaup=0

        metaup=0

        vint(23)=0d0

        vint(26)=0d0

        sigsam=0d0


C...Find limits and select tau, y*, cos(theta-hat) and tau' values,

C...in grid of phase space points.

        CALL pyklim(1)

        metau=mint(51)

        nacc=0

        DO 150 itry=1,ntry

          mint(51)=0

          IF(metau.EQ.1) goto 150

          IF(mod(itry-1,npts(2)*npts(3)*npts(4)).EQ.0) THEN

            mtau=1+(itry-1)/(npts(2)*npts(3)*npts(4))

            IF(mtau.GT.2+2*mint(72)) mtau=7

            rtau=0.5d0

C...Special case when both resonances have same mass,

C...as is often the case in process 194.

            IF(mint(72).EQ.2) THEN

              IF(abs(pmas(kcr2,1)-pmas(kcr1,1)).LT.

     &        0.01d0*(pmas(kcr2,1)+pmas(kcr1,1))) THEN

                IF(mtau.EQ.3.OR.mtau.EQ.4) THEN

                  rtau=0.4d0

                ELSEIF(mtau.EQ.5.OR.mtau.EQ.6) THEN

                  rtau=0.6d0

                ENDIF

              ENDIF

            ENDIF

            CALL pykmap(1,mtau,rtau)

            IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)

            metaup=mint(51)

          ENDIF

          IF(metaup.EQ.1) goto 150

          IF(istsb.GE.3.AND.istsb.LE.5.AND.mod(itry-1,npts(3)*npts(4))

     &    .EQ.0) THEN

            mtaup=1+mod((itry-1)/(npts(3)*npts(4)),npts(2))

            CALL pykmap(4,mtaup,0.5d0)

          ENDIF

          IF(mod(itry-1,npts(3)*npts(4)).EQ.0) THEN

            CALL pyklim(2)

            meyst=mint(51)

          ENDIF

          IF(meyst.EQ.1) goto 150

          IF(mod(itry-1,npts(4)).EQ.0) THEN

            myst=1+mod((itry-1)/npts(4),npts(3))

            IF(myst.EQ.4.AND.mint(45).NE.3) myst=5

            CALL pykmap(2,myst,0.5d0)

            CALL pyklim(3)

            mecth=mint(51)

          ENDIF

          IF(mecth.EQ.1) goto 150

          IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

            mcth=1+mod(itry-1,npts(4))

            CALL pykmap(3,mcth,0.5d0)

          ENDIF

          IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)


C...Store position and limits.

          mint(51)=0

          CALL pyklim(0)

          IF(mint(51).EQ.1) goto 150

          nacc=nacc+1

          mvarpt(nacc,1)=mtau

          mvarpt(nacc,2)=mtaup

          mvarpt(nacc,3)=myst

          mvarpt(nacc,4)=mcth

          DO 130 j=1,30

            vintpt(nacc,j)=vint(10+j)

  130     CONTINUE


C...Normal case: calculate cross-section.

          IF(istsb.NE.5) THEN

            CALL pysigh(nchn,sigs)

            IF(mwtxs.EQ.1) THEN

              CALL pyevwt(wtxs)

              sigs=wtxs*sigs

            ENDIF


C..2 -> 3: find highest value out of a number of tries.

          ELSE

            sigs=0d0

            DO 140 ikin3=1,mstp(129)

              CALL pykmap(5,0,0d0)

              IF(mint(51).EQ.1) goto 140

              CALL pysigh(nchn,sigtmp)

              IF(mwtxs.EQ.1) THEN

                CALL pyevwt(wtxs)

                sigtmp=wtxs*sigtmp

              ENDIF

              IF(sigtmp.GT.sigs) sigs=sigtmp

  140       CONTINUE

          ENDIF


C...Store cross-section.

          sigspt(nacc)=sigs

          IF(sigs.GT.sigsam) sigsam=sigs

          IF(mstp(122).GE.2) WRITE(mstu(11),5200) mtau,myst,mcth,mtaup,

     &    vint(21),vint(22),vint(23),vint(26),sigs

  150   CONTINUE

        IF(nacc.EQ.0) THEN

          WRITE(mstu(11),5100) isub

          msub(isub)=0

          goto 460

        ELSEIF(sigsam.EQ.0d0) THEN

          WRITE(mstu(11),5300) isub

          msub(isub)=0

          goto 460

        ENDIF

        IF(isub.NE.96) nposi=nposi+1


C...Calculate integrals in tau over maximal phase space limits.

        taumin=vint(11)

        taumax=vint(31)

        atau1=log(taumax/taumin)

        IF(npts(1).GE.2) THEN

          atau2=(taumax-taumin)/(taumax*taumin)

        ENDIF

        IF(npts(1).GE.4) THEN

          atau3=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))/taur1

          atau4=(atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1))/

     &    gamr1

        ENDIF

        IF(npts(1).GE.6) THEN

          atau5=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))/taur2

          atau6=(atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2))/

     &    gamr2

        ENDIF

        IF(npts(1).GT.2+2*mint(72)) THEN

          atau7=log(max(2d-6,1d0-taumin)/max(2d-6,1d0-taumax))

        ENDIF


C...Reset. Sum up cross-sections in points calculated.

        DO 320 ivar=1,4

          IF(npts(ivar).EQ.1) goto 320

          IF(isub.EQ.96.AND.ivar.EQ.4) goto 320

          nbin=npts(ivar)

          DO 170 j1=1,nbin

            narel(j1)=0

            wtrel(j1)=0d0

            coefu(j1)=0d0

            DO 160 j2=1,nbin

              wtmat(j1,j2)=0d0

  160       CONTINUE

  170     CONTINUE

          DO 180 iacc=1,nacc

            ibin=mvarpt(iacc,ivar)

            IF(ivar.EQ.1.AND.ibin.EQ.7) ibin=3+2*mint(72)

            IF(ivar.EQ.3.AND.ibin.EQ.5.AND.mint(45).NE.3) ibin=4

            narel(ibin)=narel(ibin)+1

            wtrel(ibin)=wtrel(ibin)+sigspt(iacc)


C...Sum up tau cross-section pieces in points used.

            IF(ivar.EQ.1) THEN

              tau=vintpt(iacc,11)

              wtmat(ibin,1)=wtmat(ibin,1)+1d0

              wtmat(ibin,2)=wtmat(ibin,2)+(atau1/atau2)/tau

              IF(nbin.GE.4) THEN

                wtmat(ibin,3)=wtmat(ibin,3)+(atau1/atau3)/(tau+taur1)

                wtmat(ibin,4)=wtmat(ibin,4)+(atau1/atau4)*tau/

     &          ((tau-taur1)**2+gamr1**2)

              ENDIF

              IF(nbin.GE.6) THEN

                wtmat(ibin,5)=wtmat(ibin,5)+(atau1/atau5)/(tau+taur2)

                wtmat(ibin,6)=wtmat(ibin,6)+(atau1/atau6)*tau/

     &          ((tau-taur2)**2+gamr2**2)

              ENDIF

              IF(nbin.GT.2+2*mint(72)) THEN

                wtmat(ibin,nbin)=wtmat(ibin,nbin)+(atau1/atau7)*

     &          tau/max(2d-6,1d0-tau)

              ENDIF


C...Sum up tau' cross-section pieces in points used.

            ELSEIF(ivar.EQ.2) THEN

              tau=vintpt(iacc,11)

              taup=vintpt(iacc,16)

              taupmn=vintpt(iacc,6)

              taupmx=vintpt(iacc,26)

              ataup1=log(taupmx/taupmn)

              ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)

              wtmat(ibin,1)=wtmat(ibin,1)+1d0

              wtmat(ibin,2)=wtmat(ibin,2)+(ataup1/ataup2)*

     &        (1d0-tau/taup)**3/taup

              IF(nbin.GE.3) THEN

                ataup3=log(max(2d-6,1d0-taupmn)/max(2d-6,1d0-taupmx))

                wtmat(ibin,3)=wtmat(ibin,3)+(ataup1/ataup3)*

     &          taup/max(2d-6,1d0-taup)

              ENDIF


C...Sum up y* cross-section pieces in points used.

            ELSEIF(ivar.EQ.3) THEN

              yst=vintpt(iacc,12)

              ystmin=vintpt(iacc,2)

              ystmax=vintpt(iacc,22)

              ayst0=ystmax-ystmin

              ayst1=0.5d0*(ystmax-ystmin)**2

              ayst2=ayst1

              ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))

              wtmat(ibin,1)=wtmat(ibin,1)+(ayst0/ayst1)*(yst-ystmin)

              wtmat(ibin,2)=wtmat(ibin,2)+(ayst0/ayst2)*(ystmax-yst)

              wtmat(ibin,3)=wtmat(ibin,3)+(ayst0/ayst3)/cosh(yst)

              IF(mint(45).EQ.3) THEN

                taue=vintpt(iacc,11)

                IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)

                yst0=-0.5d0*log(taue)

                ayst4=log(max(1d-6,exp(yst0-ystmin)-1d0)/

     &          max(1d-6,exp(yst0-ystmax)-1d0))

                wtmat(ibin,4)=wtmat(ibin,4)+(ayst0/ayst4)/

     &          max(1d-6,1d0-exp(yst-yst0))

              ENDIF

              IF(mint(46).EQ.3) THEN

                taue=vintpt(iacc,11)

                IF(istsb.GE.3.AND.istsb.LE.5) taue=vintpt(iacc,16)

                yst0=-0.5d0*log(taue)

                ayst5=log(max(1d-6,exp(yst0+ystmax)-1d0)/

     &          max(1d-6,exp(yst0+ystmin)-1d0))

                wtmat(ibin,nbin)=wtmat(ibin,nbin)+(ayst0/ayst5)/

     &          max(1d-6,1d0-exp(-yst-yst0))

              ENDIF


C...Sum up cos(theta-hat) cross-section pieces in points used.

            ELSE

              rm34=max(1d-20,2d0*sqm3*sqm4/(vintpt(iacc,11)*vint(2))**2)

              rsqm=1d0+rm34

              cthmax=sqrt(1d0-4d0*vint(71)**2/(taumax*vint(2)))

              cthmin=-cthmax

              IF(cthmax.GT.0.9999d0) rm34=max(rm34,2d0*vint(71)**2/

     &        (taumax*vint(2)))

              acth1=cthmax-cthmin

              acth2=log(max(rm34,rsqm-cthmin)/max(rm34,rsqm-cthmax))

              acth3=log(max(rm34,rsqm+cthmax)/max(rm34,rsqm+cthmin))

              acth4=1d0/max(rm34,rsqm-cthmax)-1d0/max(rm34,rsqm-cthmin)

              acth5=1d0/max(rm34,rsqm+cthmin)-1d0/max(rm34,rsqm+cthmax)

              cth=vintpt(iacc,13)

              wtmat(ibin,1)=wtmat(ibin,1)+1d0

              wtmat(ibin,2)=wtmat(ibin,2)+(acth1/acth2)/

     &        max(rm34,rsqm-cth)

              wtmat(ibin,3)=wtmat(ibin,3)+(acth1/acth3)/

     &        max(rm34,rsqm+cth)

              wtmat(ibin,4)=wtmat(ibin,4)+(acth1/acth4)/

     &        max(rm34,rsqm-cth)**2

              wtmat(ibin,5)=wtmat(ibin,5)+(acth1/acth5)/

     &        max(rm34,rsqm+cth)**2

            ENDIF

  180     CONTINUE


C...Check that equation system solvable.

          IF(mstp(122).GE.2) WRITE(mstu(11),5400) cvar(ivar)

          msolv=1

          wtrels=0d0

          DO 190 ibin=1,nbin

            IF(mstp(122).GE.2) WRITE(mstu(11),5500) (wtmat(ibin,ired),

     &      ired=1,nbin),wtrel(ibin)

            IF(narel(ibin).EQ.0) msolv=0

            wtrels=wtrels+wtrel(ibin)

  190     CONTINUE

          IF(abs(wtrels).LT.1d-20) msolv=0


C...Solve to find relative importance of cross-section pieces.

          IF(msolv.EQ.1) THEN

            DO 200 ibin=1,nbin

              wtreln(ibin)=max(0.1d0,wtrel(ibin)/wtrels)

  200       CONTINUE

            DO 230 ired=1,nbin-1

              DO 220 ibin=ired+1,nbin

                IF(abs(wtmat(ired,ired)).LT.1d-20) THEN

                  msolv=0

                  goto 260

                ENDIF

                rqt=wtmat(ibin,ired)/wtmat(ired,ired)

                wtrel(ibin)=wtrel(ibin)-rqt*wtrel(ired)

                DO 210 icoe=ired,nbin

                  wtmat(ibin,icoe)=wtmat(ibin,icoe)-rqt*wtmat(ired,icoe)

  210           CONTINUE

  220         CONTINUE

  230       CONTINUE

            DO 250 ired=nbin,1,-1

              DO 240 icoe=ired+1,nbin

                wtrel(ired)=wtrel(ired)-wtmat(ired,icoe)*coefu(icoe)

  240         CONTINUE

              coefu(ired)=wtrel(ired)/wtmat(ired,ired)

  250       CONTINUE

          ENDIF


C...Share evenly if failure.

  260     IF(msolv.EQ.0) THEN

            DO 270 ibin=1,nbin

              coefu(ibin)=1d0

              wtreln(ibin)=0.1d0

              IF(wtrels.GT.0d0) wtreln(ibin)=max(0.1d0,

     &        wtrel(ibin)/wtrels)

  270       CONTINUE

          ENDIF


C...Normalize coefficients, with piece shared democratically.

          coefsu=0d0

          wtrels=0d0

          DO 280 ibin=1,nbin

            coefu(ibin)=max(0d0,coefu(ibin))

            coefsu=coefsu+coefu(ibin)

            wtrels=wtrels+wtreln(ibin)

  280     CONTINUE

          IF(coefsu.GT.0d0) THEN

            DO 290 ibin=1,nbin

              coefo(ibin)=parp(122)/nbin+(1d0-parp(122))*0.5d0*

     &        (coefu(ibin)/coefsu+wtreln(ibin)/wtrels)

  290       CONTINUE

          ELSE

            DO 300 ibin=1,nbin

              coefo(ibin)=1d0/nbin

  300       CONTINUE

          ENDIF

          IF(ivar.EQ.1) ioff=0

          IF(ivar.EQ.2) ioff=17

          IF(ivar.EQ.3) ioff=7

          IF(ivar.EQ.4) ioff=12

          DO 310 ibin=1,nbin

            icof=ioff+ibin

            IF(ivar.EQ.1.AND.ibin.GT.2+2*mint(72)) icof=7

            IF(ivar.EQ.3.AND.ibin.EQ.4.AND.mint(45).NE.3) icof=icof+1

            coef(isub,icof)=coefo(ibin)

  310     CONTINUE

          IF(mstp(122).GE.2) WRITE(mstu(11),5600) cvar(ivar),

     &    (coefo(ibin),ibin=1,nbin)

  320   CONTINUE


C...Find two most promising maxima among points previously determined.

        DO 330 j=1,4

          iaccmx(j)=0

          sigsmx(j)=0d0

  330   CONTINUE

        nmax=0

        DO 390 iacc=1,nacc

          DO 340 j=1,30

            vint(10+j)=vintpt(iacc,j)

  340     CONTINUE

          IF(istsb.NE.5) THEN

            CALL pysigh(nchn,sigs)

            IF(mwtxs.EQ.1) THEN

              CALL pyevwt(wtxs)

              sigs=wtxs*sigs

            ENDIF

          ELSE

            sigs=0d0

            DO 350 ikin3=1,mstp(129)

              CALL pykmap(5,0,0d0)

              IF(mint(51).EQ.1) goto 350

              CALL pysigh(nchn,sigtmp)

              IF(mwtxs.EQ.1) THEN

                CALL pyevwt(wtxs)

                sigtmp=wtxs*sigtmp

              ENDIF

              IF(sigtmp.GT.sigs) sigs=sigtmp

  350       CONTINUE

          ENDIF

          ieq=0

          DO 360 imv=1,nmax

            IF(abs(sigs-sigsmx(imv)).LT.1d-4*(sigs+sigsmx(imv))) ieq=imv

  360     CONTINUE

          IF(ieq.EQ.0) THEN

            DO 370 imv=nmax,1,-1

              iin=imv+1

              IF(sigs.LE.sigsmx(imv)) goto 380

              iaccmx(imv+1)=iaccmx(imv)

              sigsmx(imv+1)=sigsmx(imv)

  370       CONTINUE

            iin=1

  380       iaccmx(iin)=iacc

            sigsmx(iin)=sigs

            IF(nmax.LE.1) nmax=nmax+1

          ENDIF

  390   CONTINUE


C...Read out starting position for search.

        IF(mstp(122).GE.2) WRITE(mstu(11),5700)

        sigsam=sigsmx(1)

        DO 440 imax=1,nmax

          iacc=iaccmx(imax)

          mtau=mvarpt(iacc,1)

          mtaup=mvarpt(iacc,2)

          myst=mvarpt(iacc,3)

          mcth=mvarpt(iacc,4)

          vtau=0.5d0

          vyst=0.5d0

          vcth=0.5d0

          vtaup=0.5d0


C...Starting point and step size in parameter space.

          DO 430 irpt=1,2

            DO 420 ivar=1,4

              IF(npts(ivar).EQ.1) goto 420

              IF(ivar.EQ.1) vvar=vtau

              IF(ivar.EQ.2) vvar=vtaup

              IF(ivar.EQ.3) vvar=vyst

              IF(ivar.EQ.4) vvar=vcth

              IF(ivar.EQ.1) mvar=mtau

              IF(ivar.EQ.2) mvar=mtaup

              IF(ivar.EQ.3) mvar=myst

              IF(ivar.EQ.4) mvar=mcth

              IF(irpt.EQ.1) vdel=0.1d0

              IF(irpt.EQ.2) vdel=max(0.01d0,min(0.05d0,vvar-0.02d0,

     &        0.98d0-vvar))

              IF(irpt.EQ.1) vmar=0.02d0

              IF(irpt.EQ.2) vmar=0.002d0

              imov0=1

              IF(irpt.EQ.1.AND.ivar.EQ.1) imov0=0

              DO 410 imov=imov0,8


C...Define new point in parameter space.

                IF(imov.EQ.0) THEN

                  inew=2

                  vnew=vvar

                ELSEIF(imov.EQ.1) THEN

                  inew=3

                  vnew=vvar+vdel

                ELSEIF(imov.EQ.2) THEN

                  inew=1

                  vnew=vvar-vdel

                ELSEIF(sigssm(3).GE.max(sigssm(1),sigssm(2)).AND.

     &            vvar+2d0*vdel.LT.1d0-vmar) THEN

                  vvar=vvar+vdel

                  sigssm(1)=sigssm(2)

                  sigssm(2)=sigssm(3)

                  inew=3

                  vnew=vvar+vdel

                ELSEIF(sigssm(1).GE.max(sigssm(2),sigssm(3)).AND.

     &            vvar-2d0*vdel.GT.vmar) THEN

                  vvar=vvar-vdel

                  sigssm(3)=sigssm(2)

                  sigssm(2)=sigssm(1)

                  inew=1

                  vnew=vvar-vdel

                ELSEIF(sigssm(3).GE.sigssm(1)) THEN

                  vdel=0.5d0*vdel

                  vvar=vvar+vdel

                  sigssm(1)=sigssm(2)

                  inew=2

                  vnew=vvar

                ELSE

                  vdel=0.5d0*vdel

                  vvar=vvar-vdel

                  sigssm(3)=sigssm(2)

                  inew=2

                  vnew=vvar

                ENDIF


C...Convert to relevant variables and find derived new limits.

                IF(ivar.EQ.1) THEN

                  vtau=vnew

                  CALL pykmap(1,mtau,vtau)

                  IF(istsb.GE.3.AND.istsb.LE.5) CALL pyklim(4)

                ENDIF

                IF(ivar.LE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN

                  IF(ivar.EQ.2) vtaup=vnew

                  CALL pykmap(4,mtaup,vtaup)

                ENDIF

                IF(ivar.LE.2) CALL pyklim(2)

                IF(ivar.LE.3) THEN

                  IF(ivar.EQ.3) vyst=vnew

                  CALL pykmap(2,myst,vyst)

                  CALL pyklim(3)

                ENDIF

                IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

                  IF(ivar.EQ.4) vcth=vnew

                  CALL pykmap(3,mcth,vcth)

                ENDIF

                IF(isub.EQ.96) vint(25)=vint(21)*(1d0-vint(23)**2)


C...Evaluate cross-section. Save new maximum. Final maximum.

                IF(istsb.NE.5) THEN

                  CALL pysigh(nchn,sigs)

                  IF(mwtxs.EQ.1) THEN

                    CALL pyevwt(wtxs)

                    sigs=wtxs*sigs

                  ENDIF

                ELSE

                  sigs=0d0

                  DO 400 ikin3=1,mstp(129)

                    CALL pykmap(5,0,0d0)

                    IF(mint(51).EQ.1) goto 400

                    CALL pysigh(nchn,sigtmp)

                    IF(mwtxs.EQ.1) THEN

                        CALL pyevwt(wtxs)

                        sigtmp=wtxs*sigtmp

                    ENDIF

                    IF(sigtmp.GT.sigs) sigs=sigtmp

  400             CONTINUE

                ENDIF

                sigssm(inew)=sigs

                IF(sigs.GT.sigsam) sigsam=sigs

                IF(mstp(122).GE.2) WRITE(mstu(11),5800) imax,ivar,mvar,

     &          imov,vnew,vint(21),vint(22),vint(23),vint(26),sigs

  410         CONTINUE

  420       CONTINUE

  430     CONTINUE

  440   CONTINUE

        IF(mstp(121).EQ.1) sigsam=parp(121)*sigsam

        xsec(isub,1)=1.05d0*sigsam

  450   CONTINUE

        IF(mstp(173).EQ.1.AND.isub.NE.96) xsec(isub,1)=

     &  parp(174)*xsec(isub,1)

        IF(isub.NE.96) xsec(0,1)=xsec(0,1)+xsec(isub,1)

  460 CONTINUE

      mint(51)=0


C...Print summary table.

      IF(nposi.EQ.0) THEN

        WRITE(mstu(11),5900)

        stop

      ENDIF

      IF(mstp(122).GE.1) THEN

        WRITE(mstu(11),6000)

        WRITE(mstu(11),6100)

        DO 470 isub=1,500

          IF(msub(isub).NE.1.AND.isub.NE.96) goto 470

          IF(isub.EQ.96.AND.mint(50).EQ.0) goto 470

          IF(isub.EQ.96.AND.msub(95).NE.1.AND.mstp(81).LE.0) goto 470

          IF(isub.EQ.96.AND.mint(49).EQ.0.AND.mstp(131).EQ.0) goto 470

          IF(msub(95).EQ.1.AND.(isub.EQ.11.OR.isub.EQ.12.OR.isub.EQ.13

     &    .OR.isub.EQ.28.OR.isub.EQ.53.OR.isub.EQ.68)) goto 470

          WRITE(mstu(11),6200) isub,proc(isub),xsec(isub,1)

  470   CONTINUE

        WRITE(mstu(11),6300)

      ENDIF


C...Format statements for maximization results.

 5000 FORMAT(/1x,'Coefficient optimization and maximum search for ',

     &'subprocess no',i4/1x,'Coefficient modes     tau',10x,'y*',9x,

     &'cth',9x,'tau''',7x,'sigma')

 5100 FORMAT(1x,'Warning: requested subprocess ',i3,' has no allowed ',

     &'phase space.'/1x,'Process switched off!')

 5200 FORMAT(1x,4i4,f12.8,f12.6,f12.7,f12.8,1p,d12.4)

 5300 FORMAT(1x,'Warning: requested subprocess ',i3,' has vanishing ',

     &'cross-section.'/1x,'Process switched off!')

 5400 FORMAT(1x,'Coefficients of equation system to be solved for ',a4)

 5500 FORMAT(1x,1p,8d11.3)

 5600 FORMAT(1x,'Result for ',a4,':',7f9.4)

 5700 FORMAT(1x,'Maximum search for given coefficients'/2x,'MAX VAR ',

     &'MOD MOV   VNEW',7x,'tau',7x,'y*',8x,'cth',7x,'tau''',7x,'sigma')

 5800 FORMAT(1x,4i4,f8.4,f11.7,f9.3,f11.6,f11.7,1p,d12.4)

 5900 FORMAT(1x,'Error: no requested process has non-vanishing ',

     &'cross-section.'/1x,'Execution stopped!')

 6000 FORMAT(/1x,8('*'),1x,'PYMAXI: summary of differential ',

     &'cross-section maximum search',1x,8('*'))

 6100 FORMAT(/11x,58('=')/11x,'I',38x,'I',17x,'I'/11x,'I  ISUB  ',

     &'Subprocess name',15x,'I  Maximum value  I'/11x,'I',38x,'I',

     &17x,'I'/11x,58('=')/11x,'I',38x,'I',17x,'I')

 6200 FORMAT(11x,'I',2x,i3,3x,a28,2x,'I',2x,1p,d12.4,3x,'I')

 6300 FORMAT(11x,'I',38x,'I',17x,'I'/11x,58('='))


      RETURN

      END


C*********************************************************************


C...PYPILE

C...Initializes multiplicity distribution and selects mutliplicity

C...of pileup events, i.e. several events occuring at the same

C...beam crossing.


      SUBROUTINE pypile(MPILE)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint7/sigt(0:6,0:6,0:5)

      SAVE /pydat1/,/pypars/,/pyint1/,/pyint7/

C...Local arrays and saved variables.

      dimension wti(0:200)

      SAVE imin,imax,wti,wts


C...Sum of allowed cross-sections for pileup events.

      IF(mpile.EQ.1) THEN

        vint(131)=sigt(0,0,5)

        IF(mstp(132).GE.2) vint(131)=vint(131)+sigt(0,0,4)

        IF(mstp(132).GE.3) vint(131)=vint(131)+sigt(0,0,2)+sigt(0,0,3)

        IF(mstp(132).GE.4) vint(131)=vint(131)+sigt(0,0,1)

        IF(mstp(133).LE.0) RETURN


C...Initialize multiplicity distribution at maximum.

        xnave=vint(131)*parp(131)

        IF(xnave.GT.120d0) WRITE(mstu(11),5000) xnave

        inave=max(1,min(200,nint(xnave)))

        wti(inave)=1d0

        wts=wti(inave)

        wtn=wti(inave)*inave


C...Find shape of multiplicity distribution below maximum.

        imin=inave

        DO 100 i=inave-1,1,-1

          IF(mstp(133).EQ.1) wti(i)=wti(i+1)*(i+1)/xnave

          IF(mstp(133).GE.2) wti(i)=wti(i+1)*i/xnave

          IF(wti(i).LT.1d-6) goto 110

          wts=wts+wti(i)

          wtn=wtn+wti(i)*i

          imin=i

  100   CONTINUE


C...Find shape of multiplicity distribution above maximum.

  110   imax=inave

        DO 120 i=inave+1,200

          IF(mstp(133).EQ.1) wti(i)=wti(i-1)*xnave/i

          IF(mstp(133).GE.2) wti(i)=wti(i-1)*xnave/(i-1)

          IF(wti(i).LT.1d-6) goto 130

          wts=wts+wti(i)

          wtn=wtn+wti(i)*i

          imax=i

  120   CONTINUE

  130   vint(132)=xnave

        vint(133)=wtn/wts

        IF(mstp(133).EQ.1.AND.imin.EQ.1) vint(134)=

     &  wts/(wts+wti(1)/xnave)

        IF(mstp(133).EQ.1.AND.imin.GT.1) vint(134)=1d0

        IF(mstp(133).GE.2) vint(134)=xnave


C...Pick multiplicity of pileup events.

      ELSE

        IF(mstp(133).LE.0) THEN

          mint(81)=max(1,mstp(134))

        ELSE

          wtr=wts*pyr(0)

          DO 140 i=imin,imax

            mint(81)=i

            wtr=wtr-wti(i)

            IF(wtr.LE.0d0) goto 150

  140     CONTINUE

  150     CONTINUE

        ENDIF

      ENDIF


C...Format statement for error message.

 5000 FORMAT(1x,'Warning: requested average number of events per bunch',

     &'crossing too large, ',1p,d12.4)


      RETURN

      END


C*********************************************************************


C...PYSAVE

C...Saves and restores parameter and cross section values for the

C...3 gamma-p and 6 gamma-gamma alnternatives. Also makes random

C...choice between alternatives.


      SUBROUTINE pysave(ISAVE,IGA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      SAVE /pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint5/

C...Local arrays and saved variables.

      dimension ncp(10),nsubcp(10,20),msubcp(10,20),coefcp(10,20,20),

     &ngencp(10,0:20,3),xseccp(10,0:20,3),intcp(10,20),recp(10,20)

      SAVE ncp,nsubcp,msubcp,coefcp,ngencp,xseccp,intcp,recp


C...Save list of subprocesses and cross-section information.

      IF(isave.EQ.1) THEN

        icp=0

        DO 120 i=1,500

          IF(msub(i).EQ.0.AND.i.NE.96.AND.i.NE.97) goto 120

          icp=icp+1

          nsubcp(iga,icp)=i

          msubcp(iga,icp)=msub(i)

          DO 100 j=1,20

            coefcp(iga,icp,j)=coef(i,j)

  100     CONTINUE

          DO 110 j=1,3

            ngencp(iga,icp,j)=ngen(i,j)

            xseccp(iga,icp,j)=xsec(i,j)

  110     CONTINUE

  120   CONTINUE

        ncp(iga)=icp

        DO 130 j=1,3

          ngencp(iga,0,j)=ngen(0,j)

          xseccp(iga,0,j)=xsec(0,j)

  130   CONTINUE

C...Save various common process variables.

        DO 140 j=1,10

          intcp(iga,j)=mint(40+j)

  140   CONTINUE

        intcp(iga,11)=mint(101)

        intcp(iga,12)=mint(102)

        intcp(iga,13)=mint(107)

        intcp(iga,14)=mint(108)

        intcp(iga,15)=mint(123)

        recp(iga,1)=ckin(3)


C...Save cross-section information only.

      ELSEIF(isave.EQ.2) THEN

        DO 160 icp=1,ncp(iga)

          i=nsubcp(iga,icp)

          DO 150 j=1,3

            ngencp(iga,icp,j)=ngen(i,j)

            xseccp(iga,icp,j)=xsec(i,j)

  150     CONTINUE

  160   CONTINUE

        DO 170 j=1,3

          ngencp(iga,0,j)=ngen(0,j)

          xseccp(iga,0,j)=xsec(0,j)

  170   CONTINUE


C...Choose between allowed alternatives.

      ELSEIF(isave.EQ.3.OR.isave.EQ.4) THEN

        IF(isave.EQ.4) THEN

          xsumcp=0d0

          DO 180 ig=1,mint(121)

            xsumcp=xsumcp+xseccp(ig,0,1)

  180     CONTINUE

          xsumcp=xsumcp*pyr(0)

          DO 190 ig=1,mint(121)

            iga=ig

            xsumcp=xsumcp-xseccp(ig,0,1)

            IF(xsumcp.LE.0d0) goto 200

  190     CONTINUE

  200     CONTINUE

        ENDIF


C...Restore cross-section information.

        DO 210 i=1,500

          msub(i)=0

  210   CONTINUE

        DO 240 icp=1,ncp(iga)

          i=nsubcp(iga,icp)

          msub(i)=msubcp(iga,icp)

          DO 220 j=1,20

            coef(i,j)=coefcp(iga,icp,j)

  220     CONTINUE

          DO 230 j=1,3

            ngen(i,j)=ngencp(iga,icp,j)

            xsec(i,j)=xseccp(iga,icp,j)

  230     CONTINUE

  240   CONTINUE

        DO 250 j=1,3

          ngen(0,j)=ngencp(iga,0,j)

          xsec(0,j)=xseccp(iga,0,j)

  250   CONTINUE


C...Restore various common process variables.

        DO 260 j=1,10

          mint(40+j)=intcp(iga,j)

  260   CONTINUE

        mint(101)=intcp(iga,11)

        mint(102)=intcp(iga,12)

        mint(107)=intcp(iga,13)

        mint(108)=intcp(iga,14)

        mint(123)=intcp(iga,15)

        ckin(3)=recp(iga,1)

        ckin(1)=2d0*ckin(3)


C...Sum up cross-section info (for PYSTAT).

      ELSEIF(isave.EQ.5) THEN

        DO 270 i=1,500

          msub(i)=0

          ngen(i,1)=0

          ngen(i,3)=0

          xsec(i,3)=0d0

  270   CONTINUE

        ngen(0,1)=0

        ngen(0,2)=0

        ngen(0,3)=0

        xsec(0,3)=0

        DO 290 ig=1,mint(121)

          DO 280 icp=1,ncp(ig)

            i=nsubcp(ig,icp)

            IF(msubcp(ig,icp).EQ.1) msub(i)=1

            ngen(i,1)=ngen(i,1)+ngencp(ig,icp,1)

            ngen(i,3)=ngen(i,3)+ngencp(ig,icp,3)

            xsec(i,3)=xsec(i,3)+xseccp(ig,icp,3)

  280     CONTINUE

          ngen(0,1)=ngen(0,1)+ngencp(ig,0,1)

          ngen(0,2)=ngen(0,2)+ngencp(ig,0,2)

          ngen(0,3)=ngen(0,3)+ngencp(ig,0,3)

          xsec(0,3)=xsec(0,3)+xseccp(ig,0,3)

  290   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYRAND

C...Generates quantities characterizing the high-pT scattering at the

C...parton level according to the matrix elements. Chooses incoming,

C...reacting partons, their momentum fractions and one of the possible

C...subprocesses.


      SUBROUTINE pyrand


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint7/sigt(0:6,0:6,0:5)

      common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,/pyuppr/,/pymssm/

C...Local arrays.

      dimension xpq(-25:25),pmm(2),pdif(4),bhad(4),pmmn(2)


C...Parameters and data used in elastic/diffractive treatment.

      DATA eps/0.0808d0/, alp/0.25d0/, cres/2d0/, pmrc/1.062d0/,

     &smp/0.880d0/, bhad/2.3d0,1.4d0,1.4d0,0.23d0/


C...Initial values, specifically for (first) semihard interaction.

      mint(10)=0

      mint(17)=0

      mint(18)=0

      vint(143)=1d0

      vint(144)=1d0

      mfail=0

      IF(mstp(171).EQ.1.AND.mstp(172).EQ.2) mfail=1

      isub=0

      loop=0

  100 loop=loop+1

      mint(51)=0


C...Choice of process type - first event of pileup.

      IF(mint(82).EQ.1.AND.(isub.LE.90.OR.isub.GT.96)) THEN


C...For gamma-p or gamma-gamma first pick between alternatives.

        IF(mint(121).GT.1) CALL pysave(4,iga)

        mint(122)=iga


C...For gamma + gamma with different nature, flip at random.

        IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4.AND.

     &  pyr(0).GT.0.5d0) THEN

          mintsv=mint(41)

          mint(41)=mint(42)

          mint(42)=mintsv

          mintsv=mint(45)

          mint(45)=mint(46)

          mint(46)=mintsv

          mintsv=mint(107)

          mint(107)=mint(108)

          mint(108)=mintsv

          IF(mint(47).EQ.2.OR.mint(47).EQ.3) mint(47)=5-mint(47)

        ENDIF


C...Pick process type.

        rsub=xsec(0,1)*pyr(0)

        DO 110 i=1,500

          IF(msub(i).NE.1) goto 110

          isub=i

          rsub=rsub-xsec(i,1)

          IF(rsub.LE.0d0) goto 120

  110   CONTINUE

  120   IF(isub.EQ.95) isub=96

        IF(isub.EQ.96) CALL pymult(2)


C...Choice of inclusive process type - pileup events.

      ELSEIF(mint(82).GE.2.AND.isub.EQ.0) THEN

        rsub=vint(131)*pyr(0)

        isub=96

        IF(rsub.GT.sigt(0,0,5)) isub=94

        IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)) isub=93

        IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)) isub=92

        IF(rsub.GT.sigt(0,0,5)+sigt(0,0,4)+sigt(0,0,3)+sigt(0,0,2))

     &  isub=91

        IF(isub.EQ.96) CALL pymult(2)

      ENDIF

      IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)+1

      IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)+1

      IF(isub.EQ.96.AND.loop.EQ.1.AND.mint(82).EQ.1)

     &ngen(97,1)=ngen(97,1)+1

      mint(1)=isub

      istsb=iset(isub)


C...Random choice of flavour for some SUSY processes.

      IF(isub.GE.201.AND.isub.LE.280) THEN

C...~e_L ~nu_e or ~mu_L ~nu_mu.

        IF(isub.EQ.210) THEN

          kfpr(isub,1)=ksusy1+11+2*int(0.5d0+pyr(0))

          kfpr(isub,2)=kfpr(isub,1)+1

C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).

        ELSEIF(isub.EQ.213) THEN

          kfpr(isub,1)=ksusy1+12+2*int(0.5d0+pyr(0))

          kfpr(isub,2)=kfpr(isub,1)

C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.

        ELSEIF(isub.GE.246.AND.isub.LE.259) THEN

          IF(mod(isub,2).EQ.0) THEN

            kfpr(isub,1)=ksusy1+1+int(5d0*pyr(0))

          ELSE

            kfpr(isub,1)=ksusy2+1+int(5d0*pyr(0))

          ENDIF

C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b.

        ELSEIF(isub.GE.271.AND.isub.LE.276) THEN

          IF(isub.EQ.271.OR.isub.EQ.274) THEN

            ksu1=ksusy1

            ksu2=ksusy1

          ELSEIF(isub.EQ.272.OR.isub.EQ.275) THEN

            ksu1=ksusy2

            ksu2=ksusy2

          ELSEIF(pyr(0).LT.0.5d0) THEN

            ksu1=ksusy1

            ksu2=ksusy2

          ELSE

            ksu1=ksusy2

            ksu2=ksusy1

          ENDIF

          kfpr(isub,1)=ksu1+1+int(5d0*pyr(0))

          kfpr(isub,2)=ksu2+1+int(5d0*pyr(0))

C...~q ~q(bar);  ~q = ~d, ~u, ~s, ~c or ~b.

        ELSEIF(isub.EQ.277.OR.isub.EQ.279) THEN

          kfpr(isub,1)=ksusy1+1+int(5d0*pyr(0))

          kfpr(isub,2)=kfpr(isub,1)

        ELSEIF(isub.EQ.278.OR.isub.EQ.280) THEN

          kfpr(isub,1)=ksusy2+1+int(5d0*pyr(0))

          kfpr(isub,2)=kfpr(isub,1)

        ENDIF

      ENDIF


C...Find resonances (explicit or implicit in cross-section).

      mint(72)=0

      kfr1=0

      IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN

        kfr1=kfpr(isub,1)

      ELSEIF(isub.EQ.24.OR.isub.EQ.25.OR.isub.EQ.110.OR.isub.EQ.165.OR.

     &  isub.EQ.171.OR.isub.EQ.176) THEN

        kfr1=23

      ELSEIF(isub.EQ.23.OR.isub.EQ.26.OR.isub.EQ.166.OR.isub.EQ.172.OR.

     &  isub.EQ.177) THEN

        kfr1=24

      ELSEIF(isub.GE.71.AND.isub.LE.77) THEN

        kfr1=25

        IF(mstp(46).EQ.5) THEN

          kfr1=30

          pmas(30,1)=parp(45)

          pmas(30,2)=parp(45)**3/(96d0*paru(1)*parp(47)**2)

        ENDIF

      ELSEIF(isub.EQ.194) THEN

        kfr1=54

      ENDIF

      ckmx=ckin(2)

      IF(ckmx.LE.0d0) ckmx=vint(1)

      kcr1=pycomp(kfr1)

      IF(kfr1.NE.0) THEN

        IF(ckin(1).GT.pmas(kcr1,1)+20d0*pmas(kcr1,2).OR.

     &  ckmx.LT.pmas(kcr1,1)-20d0*pmas(kcr1,2)) kfr1=0

      ENDIF

      IF(kfr1.NE.0) THEN

        taur1=pmas(kcr1,1)**2/vint(2)

        gamr1=pmas(kcr1,1)*pmas(kcr1,2)/vint(2)

        mint(72)=1

        mint(73)=kfr1

        vint(73)=taur1

        vint(74)=gamr1

      ENDIF

      IF(isub.EQ.141.OR.isub.EQ.194) THEN

        kfr2=23

        IF(isub.EQ.194) kfr2=56

        kcr2=pycomp(kfr2)

        taur2=pmas(kcr2,1)**2/vint(2)

        gamr2=pmas(kcr2,1)*pmas(kcr2,2)/vint(2)

        IF(ckin(1).GT.pmas(kcr2,1)+20d0*pmas(kcr2,2).OR.

     &  ckmx.LT.pmas(kcr2,1)-20d0*pmas(kcr2,2)) kfr2=0

        IF(kfr2.NE.0.AND.kfr1.NE.0) THEN

          mint(72)=2

          mint(74)=kfr2

          vint(75)=taur2

          vint(76)=gamr2

        ELSEIF(kfr2.NE.0) THEN

          kfr1=kfr2

          taur1=taur2

          gamr1=gamr2

          mint(72)=1

          mint(73)=kfr1

          vint(73)=taur1

          vint(74)=gamr1

        ENDIF

      ENDIF


C...Find product masses and minimum pT of process,

C...optionally with broadening according to a truncated Breit-Wigner.

      vint(63)=0d0

      vint(64)=0d0

      mint(71)=0

      vint(71)=ckin(3)

      IF(mint(82).GE.2) vint(71)=0d0

      vint(80)=1d0

      IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

        nbw=0

        DO 140 i=1,2

          pmmn(i)=0d0

          IF(kfpr(isub,i).EQ.0) THEN

          ELSEIF(mstp(42).LE.0.OR.pmas(pycomp(kfpr(isub,i)),2).LT.

     &      parp(41)) THEN

            vint(62+i)=pmas(pycomp(kfpr(isub,i)),1)**2

          ELSE

            nbw=nbw+1

C...This prevents SUSY/t particles from becoming too light.

            kflw=kfpr(isub,i)

            IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN

              kcw=pycomp(kflw)

              pmmn(i)=pmas(kcw,1)

              DO 130 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1

                IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN

                  pmsum=pmas(pycomp(kfdp(idc,1)),1)+

     &            pmas(pycomp(kfdp(idc,2)),1)

                  IF(kfdp(idc,3).NE.0) pmsum=pmsum+

     &            pmas(pycomp(kfdp(idc,3)),1)

                  pmmn(i)=min(pmmn(i),pmsum)

                ENDIF

  130         CONTINUE

            ELSEIF(kflw.EQ.6) THEN

              pmmn(i)=pmas(24,1)+pmas(5,1)

            ENDIF

          ENDIF

  140   CONTINUE

        IF(nbw.GE.1) THEN

          ckin41=ckin(41)

          ckin43=ckin(43)

          ckin(41)=max(pmmn(1),ckin(41))

          ckin(43)=max(pmmn(2),ckin(43))

          CALL pyofsh(4,0,kfpr(isub,1),kfpr(isub,2),0d0,pqm3,pqm4)

          ckin(41)=ckin41

          ckin(43)=ckin43

          IF(mint(51).EQ.1) THEN

            IF(mint(121).GT.1) CALL pysave(2,iga)

            IF(mfail.EQ.1) THEN

              msti(61)=1

              RETURN

            ENDIF

            goto 100

          ENDIF

          vint(63)=pqm3**2

          vint(64)=pqm4**2

        ENDIF

        IF(min(vint(63),vint(64)).LT.ckin(6)**2) mint(71)=1

        IF(mint(71).EQ.1) vint(71)=max(ckin(3),ckin(5))

      ENDIF


C...Prepare for additional variable choices in 2 -> 3.

      IF(istsb.EQ.5) THEN

        vint(201)=0d0

        IF(kfpr(isub,2).GT.0) vint(201)=pmas(pycomp(kfpr(isub,2)),1)

        vint(206)=vint(201)

        vint(204)=pmas(23,1)

        IF(isub.EQ.124) vint(204)=pmas(24,1)

        IF(isub.EQ.121.OR.isub.EQ.122.OR.isub.EQ.181.OR.isub.EQ.182.OR.

     &  isub.EQ.186.OR.isub.EQ.187) vint(204)=vint(201)

        vint(209)=vint(204)

      ENDIF


C...Select incoming VDM particle (rho/omega/phi/J/psi).

      IF(istsb.NE.0.AND.(mint(101).GE.2.OR.mint(102).GE.2).AND.

     &(mint(123).EQ.2.OR.mint(123).EQ.5.OR.mint(123).EQ.7)) THEN

        vrn=pyr(0)*sigt(0,0,5)

        IF(mint(101).LE.1) THEN

          i1mn=0

          i1mx=0

        ELSE

          i1mn=1

          i1mx=mint(101)

        ENDIF

        IF(mint(102).LE.1) THEN

          i2mn=0

          i2mx=0

        ELSE

          i2mn=1

          i2mx=mint(102)

        ENDIF

        DO 160 i1=i1mn,i1mx

          kfv1=110*i1+3

          DO 150 i2=i2mn,i2mx

            kfv2=110*i2+3

            vrn=vrn-sigt(i1,i2,5)

            IF(vrn.LE.0d0) goto 170

  150     CONTINUE

  160   CONTINUE

  170   IF(mint(101).GE.2) mint(103)=kfv1

        IF(mint(102).GE.2) mint(104)=kfv2

      ENDIF


      IF(istsb.EQ.0) THEN

C...Elastic scattering or single or double diffractive scattering.


C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.

        mint(103)=mint(11)

        mint(104)=mint(12)

        pmm(1)=vint(3)

        pmm(2)=vint(4)

        IF(mint(101).GE.2.OR.mint(102).GE.2) THEN

          jj=isub-90

          vrn=pyr(0)*sigt(0,0,jj)

          IF(mint(101).LE.1) THEN

            i1mn=0

            i1mx=0

          ELSE

            i1mn=1

            i1mx=mint(101)

          ENDIF

          IF(mint(102).LE.1) THEN

            i2mn=0

            i2mx=0

          ELSE

            i2mn=1

            i2mx=mint(102)

          ENDIF

          DO 190 i1=i1mn,i1mx

            kfv1=110*i1+3

            DO 180 i2=i2mn,i2mx

              kfv2=110*i2+3

              vrn=vrn-sigt(i1,i2,jj)

              IF(vrn.LE.0d0) goto 200

  180       CONTINUE

  190     CONTINUE

  200     IF(mint(101).GE.2) THEN

            mint(103)=kfv1

            pmm(1)=pymass(kfv1)

          ENDIF

          IF(mint(102).GE.2) THEN

            mint(104)=kfv2

            pmm(2)=pymass(kfv2)

          ENDIF

        ENDIF


C...Side/sides of diffractive system.

        mint(17)=0

        mint(18)=0

        IF(isub.EQ.92.OR.isub.EQ.94) mint(17)=1

        IF(isub.EQ.93.OR.isub.EQ.94) mint(18)=1


C...Find masses of particles and minimal masses of diffractive states.

        DO 210 jt=1,2

          pdif(jt)=pmm(jt)

          vint(66+jt)=pdif(jt)

          IF(mint(16+jt).EQ.1) pdif(jt)=pdif(jt)+parp(102)

  210   CONTINUE

        sh=vint(2)

        sqm1=pmm(1)**2

        sqm2=pmm(2)**2

        sqm3=pdif(1)**2

        sqm4=pdif(2)**2

        smres1=(pmm(1)+pmrc)**2

        smres2=(pmm(2)+pmrc)**2


C...Find elastic slope and lower limit diffractive slope.

        iha=max(2,iabs(mint(103))/110)

        IF(iha.GE.5) iha=1

        ihb=max(2,iabs(mint(104))/110)

        IF(ihb.GE.5) ihb=1

        IF(isub.EQ.91) THEN

          bmn=2d0*bhad(iha)+2d0*bhad(ihb)+4d0*sh**eps-4.2d0

        ELSEIF(isub.EQ.92) THEN

          bmn=max(2d0,2d0*bhad(ihb))

        ELSEIF(isub.EQ.93) THEN

          bmn=max(2d0,2d0*bhad(iha))

        ELSEIF(isub.EQ.94) THEN

          bmn=2d0*alp*4d0

        ENDIF


C...Determine maximum possible t range and coefficient of generation.

        sqla12=(sh-sqm1-sqm2)**2-4d0*sqm1*sqm2

        sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4

        tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh

        thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh

        thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*

     &  (sqm1*sqm4-sqm2*sqm3)/sh

        thl=-0.5d0*(tha+thb)

        thu=thc/thl

        thrnd=exp(max(-50d0,bmn*(thl-thu)))-1d0


C...Select diffractive mass/masses according to dm^2/m^2.

  220   DO 230 jt=1,2

          IF(mint(16+jt).EQ.0) THEN

            pdif(2+jt)=pdif(jt)

          ELSE

            pmmin=pdif(jt)

            pmmax=max(vint(2+jt),vint(1)-pdif(3-jt))

            pdif(2+jt)=pmmin*(pmmax/pmmin)**pyr(0)

          ENDIF

  230   CONTINUE

        sqm3=pdif(3)**2

        sqm4=pdif(4)**2


C..Additional mass factors, including resonance enhancement.

        IF(pdif(3)+pdif(4).GE.vint(1)) goto 220

        IF(isub.EQ.92) THEN

          fsd=(1d0-sqm3/sh)*(1d0+cres*smres1/(smres1+sqm3))

          IF(fsd.LT.pyr(0)*(1d0+cres)) goto 220

        ELSEIF(isub.EQ.93) THEN

          fsd=(1d0-sqm4/sh)*(1d0+cres*smres2/(smres2+sqm4))

          IF(fsd.LT.pyr(0)*(1d0+cres)) goto 220

        ELSEIF(isub.EQ.94) THEN

          fdd=(1d0-(pdif(3)+pdif(4))**2/sh)*(sh*smp/

     &    (sh*smp+sqm3*sqm4))*(1d0+cres*smres1/(smres1+sqm3))*

     &    (1d0+cres*smres2/(smres2+sqm4))

          IF(fdd.LT.pyr(0)*(1d0+cres)**2) goto 220

        ENDIF


C...Select t according to exp(Bmn*t) and correct to right slope.

        th=thu+log(1d0+thrnd*pyr(0))/bmn

        IF(isub.GE.92) THEN

          IF(isub.EQ.92) THEN

            badd=2d0*alp*log(sh/sqm3)

            IF(bhad(ihb).LT.1d0) badd=max(0d0,badd+2d0*bhad(ihb)-2d0)

          ELSEIF(isub.EQ.93) THEN

            badd=2d0*alp*log(sh/sqm4)

            IF(bhad(iha).LT.1d0) badd=max(0d0,badd+2d0*bhad(iha)-2d0)

          ELSEIF(isub.EQ.94) THEN

            badd=2d0*alp*(log(exp(4d0)+sh/(alp*sqm3*sqm4))-4d0)

          ENDIF

          IF(exp(max(-50d0,badd*(th-thu))).LT.pyr(0)) goto 220

        ENDIF


C...Check whether m^2 and t choices are consistent.

        sqla34=(sh-sqm3-sqm4)**2-4d0*sqm3*sqm4

        tha=sh-(sqm1+sqm2+sqm3+sqm4)+(sqm1-sqm2)*(sqm3-sqm4)/sh

        thb=sqrt(max(0d0,sqla12))*sqrt(max(0d0,sqla34))/sh

        IF(thb.LE.1d-8) goto 220

        thc=(sqm3-sqm1)*(sqm4-sqm2)+(sqm1+sqm4-sqm2-sqm3)*

     &  (sqm1*sqm4-sqm2*sqm3)/sh

        thlm=-0.5d0*(tha+thb)

        thum=thc/thlm

        IF(th.LT.thlm.OR.th.GT.thum) goto 220


C...Information to output.

        vint(21)=1d0

        vint(22)=0d0

        vint(23)=min(1d0,max(-1d0,(tha+2d0*th)/thb))

        vint(45)=th

        vint(59)=2d0*sqrt(max(0d0,-(thc+tha*th+th**2)))/thb

        vint(63)=pdif(3)**2

        vint(64)=pdif(4)**2


C...Note: in the following, by In is meant the integral over the

C...quantity multiplying coefficient cn.

C...Choose tau according to h1(tau)/tau, where

C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +

C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +

C...I1/I5*c5*1/(tau+tau_R') +

C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +

C...I1/I7*c7*tau/(1.-tau), and

C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.

      ELSEIF(istsb.GE.1.AND.istsb.LE.5) THEN

        CALL pyklim(1)

        IF(mint(51).NE.0) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          IF(mfail.EQ.1) THEN

            msti(61)=1

            RETURN

          ENDIF

          goto 100

        ENDIF

        rtau=pyr(0)

        mtau=1

        IF(rtau.GT.coef(isub,1)) mtau=2

        IF(rtau.GT.coef(isub,1)+coef(isub,2)) mtau=3

        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau=4

        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4))

     &  mtau=5

        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+

     &  coef(isub,5)) mtau=6

        IF(rtau.GT.coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+

     &  coef(isub,5)+coef(isub,6)) mtau=7

        CALL pykmap(1,mtau,pyr(0))


C...2 -> 3, 4 processes:

C...Choose tau' according to h4(tau,tau')/tau', where

C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +

C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.

        IF(istsb.GE.3.AND.istsb.LE.5) THEN

          CALL pyklim(4)

          IF(mint(51).NE.0) THEN

            IF(mint(121).GT.1) CALL pysave(2,iga)

            IF(mfail.EQ.1) THEN

              msti(61)=1

              RETURN

            ENDIF

            goto 100

          ENDIF

          rtaup=pyr(0)

          mtaup=1

          IF(rtaup.GT.coef(isub,18)) mtaup=2

          IF(rtaup.GT.coef(isub,18)+coef(isub,19)) mtaup=3

          CALL pykmap(4,mtaup,pyr(0))

        ENDIF


C...Choose y* according to h2(y*), where

C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +

C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +

C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,

C...and c1 + c2 + c3 + c4 + c5 = 1.

        CALL pyklim(2)

        IF(mint(51).NE.0) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          IF(mfail.EQ.1) THEN

            msti(61)=1

            RETURN

          ENDIF

          goto 100

        ENDIF

        ryst=pyr(0)

        myst=1

        IF(ryst.GT.coef(isub,8)) myst=2

        IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3

        IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)) myst=4

        IF(ryst.GT.coef(isub,8)+coef(isub,9)+coef(isub,10)+

     &  coef(isub,11)) myst=5

        CALL pykmap(2,myst,pyr(0))


C...2 -> 2 processes:

C...Choose cos(theta-hat) (cth) according to h3(cth), where

C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +

C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,

C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),

C...and c0 + c1 + c2 + c3 + c4 = 1.

        CALL pyklim(3)

        IF(mint(51).NE.0) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          IF(mfail.EQ.1) THEN

            msti(61)=1

            RETURN

          ENDIF

          goto 100

        ENDIF

        IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

          rcth=pyr(0)

          mcth=1

          IF(rcth.GT.coef(isub,13)) mcth=2

          IF(rcth.GT.coef(isub,13)+coef(isub,14)) mcth=3

          IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)) mcth=4

          IF(rcth.GT.coef(isub,13)+coef(isub,14)+coef(isub,15)+

     &    coef(isub,16)) mcth=5

          CALL pykmap(3,mcth,pyr(0))

        ENDIF


C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.

        IF(istsb.EQ.5) THEN

          CALL pykmap(5,0,0d0)

          IF(mint(51).NE.0) THEN

            IF(mint(121).GT.1) CALL pysave(2,iga)

            IF(mfail.EQ.1) THEN

              msti(61)=1

              RETURN

            ENDIF

            goto 100

          ENDIF

        ENDIF


C...Low-pT or multiple interactions (first semihard interaction).

      ELSEIF(istsb.EQ.9) THEN

        CALL pymult(3)

        isub=mint(1)


C...Generate user-defined process: kinematics plus weight.

      ELSEIF(istsb.EQ.11) THEN

        msti(51)=0

        CALL pyupev(isub,sigs)

        IF(nup.LE.0) THEN

          mint(51)=2

          msti(51)=1

          IF(mint(82).EQ.1) THEN

            ngen(0,1)=ngen(0,1)-1

            ngen(0,2)=ngen(0,2)-1

            ngen(isub,1)=ngen(isub,1)-1

          ENDIF

          IF(mint(121).GT.1) CALL pysave(2,iga)

          RETURN

        ENDIF


C...Construct 'trivial' kinematical variables needed.

        kfl1=kup(1,2)

        kfl2=kup(2,2)

        vint(41)=2d0*pup(1,4)/vint(1)

        vint(42)=2d0*pup(2,4)/vint(1)

        vint(21)=vint(41)*vint(42)

        vint(22)=0.5d0*log(vint(41)/vint(42))

        vint(44)=vint(21)*vint(2)

        vint(43)=sqrt(max(0d0,vint(44)))

        vint(56)=q2up(0)

        vint(55)=sqrt(max(0d0,vint(56)))


C...Construct other kinematical variables needed (approximately).

        vint(23)=0d0

        vint(26)=vint(21)

        vint(45)=-0.5d0*vint(44)

        vint(46)=-0.5d0*vint(44)

        vint(49)=vint(43)

        vint(50)=vint(44)

        vint(51)=vint(55)

        vint(52)=vint(56)

        vint(53)=vint(55)

        vint(54)=vint(56)

        vint(25)=0d0

        vint(48)=0d0

        DO 240 iup=3,nup

          IF(kup(iup,1).EQ.1) vint(25)=vint(25)+2d0*(pup(iup,5)**2+

     &    pup(iup,1)**2+pup(iup,2)**2)/vint(1)

          IF(kup(iup,1).EQ.1) vint(48)=vint(48)+0.5d0*(pup(iup,1)**2+

     &    pup(iup,2)**2)

  240   CONTINUE

        vint(47)=sqrt(vint(48))


C...Calculate parton distribution weights.

        IF(mint(47).GE.2) THEN

          DO 260 i=3-min(2,mint(45)),min(2,mint(46))

            mint(105)=mint(102+i)

            mint(109)=mint(106+i)

            IF(mstp(57).LE.1) THEN

              CALL pypdfu(mint(10+i),vint(40+i),q2up(0),xpq)

            ELSE

              CALL pypdfl(mint(10+i),vint(40+i),q2up(0),xpq)

            ENDIF

            DO 250 kfl=-25,25

              xsfx(i,kfl)=xpq(kfl)

  250       CONTINUE

  260     CONTINUE

        ENDIF

      ENDIF


C...Choose azimuthal angle.

      vint(24)=paru(2)*pyr(0)


C...Check against user cuts on kinematics at parton level.

      mint(51)=0

      IF((isub.LE.90.OR.isub.GT.100).AND.istsb.LE.10) CALL pyklim(0)

      IF(mint(51).NE.0) THEN

        IF(mint(121).GT.1) CALL pysave(2,iga)

        IF(mfail.EQ.1) THEN

          msti(61)=1

          RETURN

        ENDIF

        goto 100

      ENDIF

      IF(mint(82).EQ.1.AND.mstp(141).GE.1.AND.istsb.LE.10) THEN

        mcut=0

        IF(msub(91)+msub(92)+msub(93)+msub(94)+msub(95).EQ.0)

     &  CALL pykcut(mcut)

        IF(mcut.NE.0) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          IF(mfail.EQ.1) THEN

            msti(61)=1

            RETURN

          ENDIF

          goto 100

        ENDIF

      ENDIF


C...Calculate differential cross-section for different subprocesses.

      IF(istsb.LE.10) CALL pysigh(nchn,sigs)

      sigsor=sigs

      siglpt=sigt(0,0,5)


C...Multiply cross-section by user-defined weights.

      IF(mstp(173).EQ.1) THEN

        sigs=parp(173)*sigs

        DO 270 ichn=1,nchn

          sigh(ichn)=parp(173)*sigh(ichn)

  270   CONTINUE

        siglpt=parp(173)*siglpt

      ENDIF

      wtxs=1d0

      sigswt=sigs

      vint(99)=1d0

      vint(100)=1d0

      IF(mint(82).EQ.1.AND.mstp(142).GE.1) THEN

        IF(isub.NE.96.AND.msub(91)+msub(92)+msub(93)+msub(94)+

     &  msub(95).EQ.0) CALL pyevwt(wtxs)

        sigswt=wtxs*sigs

        vint(99)=wtxs

        IF(mstp(142).EQ.1) vint(100)=1d0/wtxs

      ENDIF


C...Calculations for Monte Carlo estimate of all cross-sections.

      IF(mint(82).EQ.1.AND.isub.LE.90.OR.isub.GE.96) THEN

        IF(mstp(142).LE.1) THEN

          xsec(isub,2)=xsec(isub,2)+sigs

        ELSE

          xsec(isub,2)=xsec(isub,2)+sigswt

        ENDIF

      ELSEIF(mint(82).EQ.1) THEN

        xsec(isub,2)=xsec(isub,2)+sigs

      ENDIF

      IF((isub.EQ.95.OR.isub.EQ.96).AND.loop.EQ.1.AND.mint(82).EQ.1)

     &xsec(97,2)=xsec(97,2)+siglpt


C...Multiple interactions: store results of cross-section calculation.

      IF(mint(50).EQ.1.AND.mstp(82).GE.3) THEN

        vint(153)=sigsor

        CALL pymult(4)

      ENDIF


C...Check that weight not negative.

      viol=sigswt/xsec(isub,1)

      IF(isub.EQ.96.AND.mstp(173).EQ.1) viol=viol/parp(174)

      IF(mstp(123).LE.0) THEN

        IF(viol.LT.-1d-3) THEN

          WRITE(mstu(11),5000) viol,ngen(0,3)+1

          IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),

     &    vint(22),vint(23),vint(26)

          stop

        ENDIF

      ELSE

        IF(viol.LT.min(-1d-3,vint(109))) THEN

          vint(109)=viol

          WRITE(mstu(11),5200) viol,ngen(0,3)+1

          IF(mstp(122).GE.1) WRITE(mstu(11),5100) isub,vint(21),

     &    vint(22),vint(23),vint(26)

        ENDIF

      ENDIF


C...Weighting using estimate of maximum of differential cross-section.

      IF(mfail.EQ.0) THEN

        IF(viol.LT.pyr(0)) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          goto 100

        ENDIF

      ELSEIF(isub.NE.95.AND.isub.NE.96) THEN

        IF(viol.LT.pyr(0)) THEN

          msti(61)=1

          IF(mint(121).GT.1) CALL pysave(2,iga)

          RETURN

        ENDIF

      ELSE

        ratnd=siglpt/xsec(95,1)

        IF(loop.EQ.1.AND.ratnd.LT.pyr(0)) THEN

          msti(61)=1

          IF(mint(121).GT.1) CALL pysave(2,iga)

          RETURN

        ENDIF

        viol=viol/ratnd

        IF(viol.LT.pyr(0)) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          goto 100

        ENDIF

      ENDIF


C...Check for possible violation of estimated maximum of differential

C...cross-section used in weighting.

      IF(mstp(123).LE.0) THEN

        IF(viol.GT.1d0) THEN

          WRITE(mstu(11),5300) viol,ngen(0,3)+1

          IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),

     &    vint(22),vint(23),vint(26)

          stop

        ENDIF

      ELSEIF(mstp(123).EQ.1) THEN

        IF(viol.GT.vint(108)) THEN

          vint(108)=viol

          IF(viol.GT.1d0) THEN

            mint(10)=1

            WRITE(mstu(11),5400) viol,ngen(0,3)+1

            IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),

     &      vint(22),vint(23),vint(26)

          ENDIF

        ENDIF

      ELSEIF(viol.GT.vint(108)) THEN

        vint(108)=viol

        IF(viol.GT.1d0) THEN

          mint(10)=1

          xdif=xsec(isub,1)*(viol-1d0)

          xsec(isub,1)=xsec(isub,1)+xdif

          IF(msub(isub).EQ.1.AND.(isub.LE.90.OR.isub.GT.96))

     &    xsec(0,1)=xsec(0,1)+xdif

          WRITE(mstu(11),5400) viol,ngen(0,3)+1

          IF(mstp(122).GE.2) WRITE(mstu(11),5100) isub,vint(21),

     &    vint(22),vint(23),vint(26)

          IF(isub.LE.9) THEN

            WRITE(mstu(11),5500) isub,xsec(isub,1)

          ELSEIF(isub.LE.99) THEN

            WRITE(mstu(11),5600) isub,xsec(isub,1)

          ELSE

            WRITE(mstu(11),5700) isub,xsec(isub,1)

          ENDIF

          vint(108)=1d0

        ENDIF

      ENDIF


C...Multiple interactions: choose impact parameter.

      vint(148)=1d0

      IF(mint(50).EQ.1.AND.(isub.LE.90.OR.isub.GE.96).AND.

     &mstp(82).GE.3) THEN

        CALL pymult(5)

        IF(vint(150).LT.pyr(0)) THEN

          IF(mint(121).GT.1) CALL pysave(2,iga)

          IF(mfail.EQ.1) THEN

            msti(61)=1

            RETURN

          ENDIF

          goto 100

        ENDIF

      ENDIF

      IF(mint(82).EQ.1) ngen(0,2)=ngen(0,2)+1

      IF(mint(82).EQ.1.AND.msub(95).EQ.1) THEN

        IF(isub.LE.90.OR.isub.GE.95) ngen(95,1)=ngen(95,1)+1

        IF(isub.LE.90.OR.isub.GE.96) ngen(96,2)=ngen(96,2)+1

      ENDIF

      IF(isub.LE.90.OR.isub.GE.96) mint(31)=mint(31)+1


C...Choose flavour of reacting partons (and subprocess).

      IF(istsb.GE.11) goto 290

      rsigs=sigs*pyr(0)

      qt2=vint(48)

      rqqbar=parp(87)*(1d0-(qt2/(qt2+(parp(88)*parp(82))**2))**2)

      IF(isub.NE.95.AND.(isub.NE.96.OR.mstp(82).LE.1.OR.

     &pyr(0).GT.rqqbar)) THEN

        DO 280 ichn=1,nchn

          kfl1=isig(ichn,1)

          kfl2=isig(ichn,2)

          mint(2)=isig(ichn,3)

          rsigs=rsigs-sigh(ichn)

          IF(rsigs.LE.0d0) goto 290

  280   CONTINUE


C...Multiple interactions: choose qqbar preferentially at small pT.

      ELSEIF(isub.EQ.96) THEN

        mint(105)=mint(103)

        mint(109)=mint(107)

        CALL pyspli(mint(11),21,kfl1,kfldum)

        mint(105)=mint(104)

        mint(109)=mint(108)

        CALL pyspli(mint(12),21,kfl2,kfldum)

        mint(1)=11

        mint(2)=1

        IF(kfl1.EQ.kfl2.AND.pyr(0).LT.0.5d0) mint(2)=2


C...Low-pT: choose string drawing configuration.

      ELSE

        kfl1=21

        kfl2=21

        rsigs=6d0*pyr(0)

        mint(2)=1

        IF(rsigs.GT.1d0) mint(2)=2

        IF(rsigs.GT.2d0) mint(2)=3

      ENDIF


C...Reassign QCD process. Partons before initial state radiation.

  290 IF(mint(2).GT.10) THEN

        mint(1)=mint(2)/10

        mint(2)=mod(mint(2),10)

      ENDIF

      IF(mint(82).EQ.1.AND.mstp(111).GE.0) ngen(mint(1),2)=

     &ngen(mint(1),2)+1

      mint(15)=kfl1

      mint(16)=kfl2

      mint(13)=mint(15)

      mint(14)=mint(16)

      vint(141)=vint(41)

      vint(142)=vint(42)

      vint(151)=0d0

      vint(152)=0d0


C...Calculate x value of photon for parton inside photon inside e.

      DO 320 jt=1,2

        mint(18+jt)=0

        vint(154+jt)=0d0

        mspli=0

        IF(jt.EQ.1.AND.mint(43).LE.2) mspli=1

        IF(jt.EQ.2.AND.mod(mint(43),2).EQ.1) mspli=1

        IF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) mspli=mspli+1

        IF(mspli.EQ.2) THEN

          kflh=mint(14+jt)

          xhrd=vint(140+jt)

          q2hrd=vint(54)

          mint(105)=mint(102+jt)

          mint(109)=mint(106+jt)

          IF(mstp(57).LE.1) THEN

            CALL pypdfu(22,xhrd,q2hrd,xpq)

          ELSE

            CALL pypdfl(22,xhrd,q2hrd,xpq)

          ENDIF

          wtmx=4d0*xpq(kflh)

          IF(mstp(13).EQ.2) THEN

            q2pms=q2hrd/pmas(11,1)**2

            wtmx=wtmx*log(max(2d0,q2pms*(1d0-xhrd)/xhrd**2))

          ENDIF

  300     xe=xhrd**pyr(0)

          xg=min(0.999999d0,xhrd/xe)

          IF(mstp(57).LE.1) THEN

            CALL pypdfu(22,xg,q2hrd,xpq)

          ELSE

            CALL pypdfl(22,xg,q2hrd,xpq)

          ENDIF

          wt=(1d0+(1d0-xe)**2)*xpq(kflh)

          IF(mstp(13).EQ.2) wt=wt*log(max(2d0,q2pms*(1d0-xe)/xe**2))

          IF(wt.LT.pyr(0)*wtmx) goto 300

          mint(18+jt)=1

          vint(154+jt)=xe

          DO 310 kfls=-25,25

            xsfx(jt,kfls)=xpq(kfls)

  310     CONTINUE

        ENDIF

  320 CONTINUE


C...Pick scale where photon is resolved.

      IF(mint(107).EQ.3) vint(283)=parp(15)**2*

     &(vint(54)/parp(15)**2)**pyr(0)

      IF(mint(108).EQ.3) vint(284)=parp(15)**2*

     &(vint(54)/parp(15)**2)**pyr(0)

      IF(mint(121).GT.1) CALL pysave(2,iga)


C...Format statements for differential cross-section maximum violations.

 5000 FORMAT(/1x,'Error: negative cross-section fraction',1p,d11.3,1x,

     &'in event',1x,i7,'D0'/1x,'Execution stopped!')

 5100 FORMAT(1x,'ISUB = ',i3,'; Point of violation:'/1x,'tau =',1p,

     &d11.3,', y* =',d11.3,', cthe = ',0p,f11.7,', tau'' =',1p,d11.3)

 5200 FORMAT(/1x,'Warning: negative cross-section fraction',1p,d11.3,1x,

     &'in event',1x,i7)

 5300 FORMAT(/1x,'Error: maximum violated by',1p,d11.3,1x,

     &'in event',1x,i7,'D0'/1x,'Execution stopped!')

 5400 FORMAT(/1x,'Advisory warning: maximum violated by',1p,d11.3,1x,

     &'in event',1x,i7)

 5500 FORMAT(1x,'XSEC(',i1,',1) increased to',1p,d11.3)

 5600 FORMAT(1x,'XSEC(',i2,',1) increased to',1p,d11.3)

 5700 FORMAT(1x,'XSEC(',i3,',1) increased to',1p,d11.3)


      RETURN

      END


C*********************************************************************


C...PYSCAT

C...Finds outgoing flavours and event type; sets up the kinematics

C...and colour flow of the hard scattering


      SUBROUTINE pyscat


C...Double precision and integer declarations

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyuppr/,/pyssmt/

C...Local arrays and saved variables

      dimension wdtp(0:200),wdte(0:200,0:5),pmq(2),z(2),cthe(2),

     &phi(2),kuppo(20),vintsv(41:66)

      SAVE vintsv


C...Read out process

      isub=mint(1)

      isubsv=isub


C...Restore information for low-pT processes

      IF(isub.EQ.95.AND.mint(57).GE.1) THEN

        DO 100 j=41,66

  100   vint(j)=vintsv(j)

      ENDIF


C...Convert H' or A process into equivalent H one

      ihigg=1

      kfhigg=25

      IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.

     &isub.LE.190)) THEN

        ihigg=2

        IF(mod(isub-1,10).GE.5) ihigg=3

        kfhigg=33+ihigg

        IF(isub.EQ.151.OR.isub.EQ.156) isub=3

        IF(isub.EQ.152.OR.isub.EQ.157) isub=102

        IF(isub.EQ.153.OR.isub.EQ.158) isub=103

        IF(isub.EQ.171.OR.isub.EQ.176) isub=24

        IF(isub.EQ.172.OR.isub.EQ.177) isub=26

        IF(isub.EQ.173.OR.isub.EQ.178) isub=123

        IF(isub.EQ.174.OR.isub.EQ.179) isub=124

        IF(isub.EQ.181.OR.isub.EQ.186) isub=121

        IF(isub.EQ.182.OR.isub.EQ.187) isub=122

      ENDIF


C...Choice of subprocess, number of documentation lines

      idoc=6+iset(isub)

      IF(isub.EQ.95) idoc=8

      IF(iset(isub).EQ.5) idoc=9

      IF(iset(isub).EQ.11) idoc=4+nup

      mint(3)=idoc-6

      IF(idoc.GE.9.AND.iset(isub).LE.4) idoc=idoc+2

      mint(4)=idoc

      ipu1=mint(84)+1

      ipu2=mint(84)+2

      ipu3=mint(84)+3

      ipu4=mint(84)+4

      ipu5=mint(84)+5

      ipu6=mint(84)+6


C...Reset K, P and V vectors. Store incoming particles

      DO 120 jt=1,mstp(126)+20

        i=mint(83)+jt

        DO 110 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  110   CONTINUE

  120 CONTINUE

      DO 140 jt=1,2

        i=mint(83)+jt

        k(i,1)=21

        k(i,2)=mint(10+jt)

        DO 130 j=1,5

          p(i,j)=vint(285+5*jt+j)

  130   CONTINUE

  140 CONTINUE

      mint(6)=2

      kfres=0


C...Store incoming partons in their CM-frame

      sh=vint(44)

      shr=sqrt(sh)

      shp=vint(26)*vint(2)

      shpr=sqrt(shp)

      shuser=shr

      IF(iset(isub).GE.3.AND.iset(isub).LE.5) shuser=shpr

      DO 150 jt=1,2

        i=mint(84)+jt

        k(i,1)=14

        k(i,2)=mint(14+jt)

        k(i,3)=mint(83)+2+jt

        p(i,3)=0.5d0*shuser*(-1d0)**(jt-1)

        p(i,4)=0.5d0*shuser

  150 CONTINUE


C...Copy incoming partons to documentation lines

      DO 170 jt=1,2

        i1=mint(83)+4+jt

        i2=mint(84)+jt

        k(i1,1)=21

        k(i1,2)=k(i2,2)

        k(i1,3)=i1-2

        DO 160 j=1,5

          p(i1,j)=p(i2,j)

  160   CONTINUE

  170 CONTINUE


C...Choose new quark/lepton flavour for relevant annihilation graphs

      IF(isub.EQ.12.OR.isub.EQ.53.OR.isub.EQ.54.OR.isub.EQ.58) THEN

        iglga=21

        IF(isub.EQ.58) iglga=22

        CALL pywidt(iglga,sh,wdtp,wdte)

  180   rkfl=(wdte(0,1)+wdte(0,2)+wdte(0,4))*pyr(0)

        DO 190 i=1,mdcy(iglga,3)

          kflf=kfdp(i+mdcy(iglga,2)-1,1)

          rkfl=rkfl-(wdte(i,1)+wdte(i,2)+wdte(i,4))

          IF(rkfl.LE.0d0) goto 200

  190   CONTINUE

  200   CONTINUE

        IF(isub.EQ.12.AND.mstp(5).EQ.1.AND.iabs(mint(15)).LE.2.AND.

     &  iabs(kflf).GE.3) THEN

          facqqb=vint(58)**2*4d0/9d0*(vint(45)**2+vint(46)**2)/

     &    vint(44)**2

          faccib=vint(46)**2/paru(155)**4

          IF(facqqb/(facqqb+faccib).LT.pyr(0)) goto 180

        ELSEIF(isub.EQ.54) THEN

          IF((kchg(pycomp(kflf),1)/2d0)**2.LT.pyr(0)) goto 180

        ELSEIF(isub.EQ.58) THEN

          IF((kchg(pycomp(kflf),1)/3d0)**2.LT.pyr(0)) goto 180

        ENDIF

      ENDIF


C...Final state flavours and colour flow: default values

      js=1

      mint(21)=mint(15)

      mint(22)=mint(16)

      mint(23)=0

      mint(24)=0

      kcc=20

      kcs=isign(1,mint(15))


      IF(iset(isub).EQ.11) THEN

C...User-defined processes: find products

        irup=0

        DO 210 iup=3,nup

          IF(kup(iup,1).NE.1) THEN

          ELSEIF(irup.LE.5) THEN

            irup=irup+1

            mint(20+irup)=kup(iup,2)

          ENDIF

  210   CONTINUE


      ELSEIF(isub.LE.10) THEN

        IF(isub.EQ.1) THEN

C...f + fbar -> gamma*/Z0

          kfres=23


        ELSEIF(isub.EQ.2) THEN

C...f + fbar' -> W+/-

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          kfres=isign(24,kch1+kch2)


        ELSEIF(isub.EQ.3) THEN

C...f + fbar -> h0 (or H0, or A0)

          kfres=kfhigg


        ELSEIF(isub.EQ.4) THEN

C...gamma + W+/- -> W+/-


        ELSEIF(isub.EQ.5) THEN

C...Z0 + Z0 -> h0

          xh=sh/shp

          mint(21)=mint(15)

          mint(22)=mint(16)

          pmq(1)=pymass(mint(21))

          pmq(2)=pymass(mint(22))

  220     jt=int(1.5d0+pyr(0))

          zmin=2d0*pmq(jt)/shpr

          zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/

     &    (shpr*(shpr-pmq(3-jt)))

          zmax=min(1d0-xh,zmax)

          z(jt)=zmin+(zmax-zmin)*pyr(0)

          IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.

     &    (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 220

          sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 220

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)

          cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(jt)=min(1d0,max(-1d0,cthe(jt)))

          z(3-jt)=1d0-xh/(1d0-z(jt))

          sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 220

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)

          cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))

          phir=paru(2)*pyr(0)

          cphi=cos(phir)

          ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*

     &    sqrt(1d0-cthe(2)**2)*cphi

          z1=2d0-z(jt)

          z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)

          z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp

          z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*

     &    pmq(3-jt)**2/shp))

          zmin=2d0*pmq(3-jt)/shpr

          zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))

          zmax=min(1d0-xh,zmax)

          IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 220

          kcc=22

          kfres=25


        ELSEIF(isub.EQ.6) THEN

C...Z0 + W+/- -> W+/-


        ELSEIF(isub.EQ.7) THEN

C...W+ + W- -> Z0


        ELSEIF(isub.EQ.8) THEN

C...W+ + W- -> h0

          xh=sh/shp

  230     DO 260 jt=1,2

            i=mint(14+jt)

            ia=iabs(i)

            IF(ia.LE.10) THEN

              rvckm=vint(180+i)*pyr(0)

              DO 240 j=1,mstp(1)

                ib=2*j-1+mod(ia,2)

                ipm=(5-isign(1,i))/2

                idc=j+mdcy(ia,2)+2

                IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 240

                mint(20+jt)=isign(ib,i)

                rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

                IF(rvckm.LE.0d0) goto 250

  240         CONTINUE

            ELSE

              ib=2*((ia+1)/2)-1+mod(ia,2)

              mint(20+jt)=isign(ib,i)

            ENDIF

  250       pmq(jt)=pymass(mint(20+jt))

  260     CONTINUE

          jt=int(1.5d0+pyr(0))

          zmin=2d0*pmq(jt)/shpr

          zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/

     &    (shpr*(shpr-pmq(3-jt)))

          zmax=min(1d0-xh,zmax)

          IF(zmin.GE.zmax) goto 230

          z(jt)=zmin+(zmax-zmin)*pyr(0)

          IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.

     &    (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 230

          sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 230

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)

          cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(jt)=min(1d0,max(-1d0,cthe(jt)))

          z(3-jt)=1d0-xh/(1d0-z(jt))

          sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 230

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)

          cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))

          phir=paru(2)*pyr(0)

          cphi=cos(phir)

          ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*

     &    sqrt(1d0-cthe(2)**2)*cphi

          z1=2d0-z(jt)

          z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)

          z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp

          z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*

     &    pmq(3-jt)**2/shp))

          zmin=2d0*pmq(3-jt)/shpr

          zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))

          zmax=min(1d0-xh,zmax)

          IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 230

          kcc=22

          kfres=25


        ELSEIF(isub.EQ.10) THEN

C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2

          IF(mint(2).EQ.1) THEN

            kcc=22

          ELSE

C...W exchange: need to mix flavours according to CKM matrix

            DO 280 jt=1,2

              i=mint(14+jt)

              ia=iabs(i)

              IF(ia.LE.10) THEN

                rvckm=vint(180+i)*pyr(0)

                DO 270 j=1,mstp(1)

                  ib=2*j-1+mod(ia,2)

                  ipm=(5-isign(1,i))/2

                  idc=j+mdcy(ia,2)+2

                  IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 270

                  mint(20+jt)=isign(ib,i)

                  rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

                  IF(rvckm.LE.0d0) goto 280

  270           CONTINUE

              ELSE

                ib=2*((ia+1)/2)-1+mod(ia,2)

                mint(20+jt)=isign(ib,i)

              ENDIF

  280       CONTINUE

            kcc=22

          ENDIF

        ENDIF


      ELSEIF(isub.LE.20) THEN

        IF(isub.EQ.11) THEN

C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2


        ELSEIF(isub.EQ.12) THEN

C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2

          mint(21)=isign(kflf,mint(15))

          mint(22)=-mint(21)

          kcc=4


        ELSEIF(isub.EQ.13) THEN

C...f + fbar -> g + g; th arbitrary

          mint(21)=21

          mint(22)=21

          kcc=mint(2)+4


        ELSEIF(isub.EQ.14) THEN

C...f + fbar -> g + gamma; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=21

          mint(23-js)=22

          kcc=17+js


        ELSEIF(isub.EQ.15) THEN

C...f + fbar -> g + Z0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=21

          mint(23-js)=23

          kcc=17+js


        ELSEIF(isub.EQ.16) THEN

C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mint(15)*(kch1+kch2).LT.0) js=2

          mint(20+js)=21

          mint(23-js)=isign(24,kch1+kch2)

          kcc=17+js


        ELSEIF(isub.EQ.17) THEN

C...f + fbar -> g + h0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=21

          mint(23-js)=25

          kcc=17+js


        ELSEIF(isub.EQ.18) THEN

C...f + fbar -> gamma + gamma; th arbitrary

          mint(21)=22

          mint(22)=22


        ELSEIF(isub.EQ.19) THEN

C...f + fbar -> gamma + Z0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=22

          mint(23-js)=23


        ELSEIF(isub.EQ.20) THEN

C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or

C...(p(fbar')-p(W+))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mint(15)*(kch1+kch2).LT.0) js=2

          mint(20+js)=22

          mint(23-js)=isign(24,kch1+kch2)

        ENDIF


      ELSEIF(isub.LE.30) THEN

        IF(isub.EQ.21) THEN

C...f + fbar -> gamma + h0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=22

          mint(23-js)=25


        ELSEIF(isub.EQ.22) THEN

C...f + fbar -> Z0 + Z0; th arbitrary

          mint(21)=23

          mint(22)=23


        ELSEIF(isub.EQ.23) THEN

C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mint(15)*(kch1+kch2).LT.0) js=2

          mint(20+js)=23

          mint(23-js)=isign(24,kch1+kch2)


        ELSEIF(isub.EQ.24) THEN

C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=23

          mint(23-js)=kfhigg


        ELSEIF(isub.EQ.25) THEN

C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2

          mint(21)=-isign(24,mint(15))

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.26) THEN

C...f + fbar' -> W+/- + h0 (or H0, or A0);

C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mint(15)*(kch1+kch2).GT.0) js=2

          mint(20+js)=isign(24,kch1+kch2)

          mint(23-js)=kfhigg


        ELSEIF(isub.EQ.27) THEN

C...f + fbar -> h0 + h0


        ELSEIF(isub.EQ.28) THEN

C...f + g -> f + g; th = (p(f)-p(f))**2

          kcc=mint(2)+6

          IF(mint(15).EQ.21) kcc=kcc+2

          IF(mint(15).NE.21) kcs=isign(1,mint(15))

          IF(mint(16).NE.21) kcs=isign(1,mint(16))


        ELSEIF(isub.EQ.29) THEN

C...f + g -> f + gamma; th = (p(f)-p(f))**2

          IF(mint(15).EQ.21) js=2

          mint(23-js)=22

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.30) THEN

C...f + g -> f + Z0; th = (p(f)-p(f))**2

          IF(mint(15).EQ.21) js=2

          mint(23-js)=23

          kcc=15+js

          kcs=isign(1,mint(14+js))

        ENDIF


      ELSEIF(isub.LE.40) THEN

        IF(isub.EQ.31) THEN

C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(24,kchg(ia,1)*i)

          rvckm=vint(180+i)*pyr(0)

          DO 290 j=1,mstp(1)

            ib=2*j-1+mod(ia,2)

            ipm=(5-isign(1,i))/2

            idc=j+mdcy(ia,2)+2

            IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 290

            mint(20+js)=isign(ib,i)

            rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

            IF(rvckm.LE.0d0) goto 300

  290     CONTINUE

  300     kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.32) THEN

C...f + g -> f + h0; th = (p(f)-p(f))**2

          IF(mint(15).EQ.21) js=2

          mint(23-js)=25

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.33) THEN

C...f + gamma -> f + g; th=(p(f)-p(f))**2

          IF(mint(15).EQ.22) js=2

          mint(23-js)=21

          kcc=24+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.34) THEN

C...f + gamma -> f + gamma; th=(p(f)-p(f))**2

          IF(mint(15).EQ.22) js=2

          kcc=22

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.35) THEN

C...f + gamma -> f + Z0; th=(p(f)-p(f))**2

          IF(mint(15).EQ.22) js=2

          mint(23-js)=23

          kcc=22


        ELSEIF(isub.EQ.36) THEN

C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2

          IF(mint(15).EQ.22) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(24,kchg(ia,1)*i)

          IF(ia.LE.10) THEN

            rvckm=vint(180+i)*pyr(0)

            DO 310 j=1,mstp(1)

              ib=2*j-1+mod(ia,2)

              ipm=(5-isign(1,i))/2

              idc=j+mdcy(ia,2)+2

              IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 310

              mint(20+js)=isign(ib,i)

              rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

              IF(rvckm.LE.0d0) goto 320

  310       CONTINUE

          ELSE

            ib=2*((ia+1)/2)-1+mod(ia,2)

            mint(20+js)=isign(ib,i)

          ENDIF

  320     kcc=22


        ELSEIF(isub.EQ.37) THEN

C...f + gamma -> f + h0


        ELSEIF(isub.EQ.38) THEN

C...f + Z0 -> f + g


        ELSEIF(isub.EQ.39) THEN

C...f + Z0 -> f + gamma


        ELSEIF(isub.EQ.40) THEN

C...f + Z0 -> f + Z0

        ENDIF


      ELSEIF(isub.LE.50) THEN

        IF(isub.EQ.41) THEN

C...f + Z0 -> f' + W+/-


        ELSEIF(isub.EQ.42) THEN

C...f + Z0 -> f + h0


        ELSEIF(isub.EQ.43) THEN

C...f + W+/- -> f' + g


        ELSEIF(isub.EQ.44) THEN

C...f + W+/- -> f' + gamma


        ELSEIF(isub.EQ.45) THEN

C...f + W+/- -> f' + Z0


        ELSEIF(isub.EQ.46) THEN

C...f + W+/- -> f' + W+/-


        ELSEIF(isub.EQ.47) THEN

C...f + W+/- -> f' + h0


        ELSEIF(isub.EQ.48) THEN

C...f + h0 -> f + g


        ELSEIF(isub.EQ.49) THEN

C...f + h0 -> f + gamma


        ELSEIF(isub.EQ.50) THEN

C...f + h0 -> f + Z0

        ENDIF


      ELSEIF(isub.LE.60) THEN

        IF(isub.EQ.51) THEN

C...f + h0 -> f' + W+/-


        ELSEIF(isub.EQ.52) THEN

C...f + h0 -> f + h0


        ELSEIF(isub.EQ.53) THEN

C...g + g -> f + fbar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kflf,kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10


        ELSEIF(isub.EQ.54) THEN

C...g + gamma -> f + fbar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kflf,kcs)

          mint(22)=-mint(21)

          kcc=27

          IF(mint(16).EQ.21) kcc=28


        ELSEIF(isub.EQ.55) THEN

C...g + Z0 -> f + fbar


        ELSEIF(isub.EQ.56) THEN

C...g + W+/- -> f + fbar'


        ELSEIF(isub.EQ.57) THEN

C...g + h0 -> f + fbar


        ELSEIF(isub.EQ.58) THEN

C...gamma + gamma -> f + fbar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kflf,kcs)

          mint(22)=-mint(21)

          kcc=21


        ELSEIF(isub.EQ.59) THEN

C...gamma + Z0 -> f + fbar


        ELSEIF(isub.EQ.60) THEN

C...gamma + W+/- -> f + fbar'

        ENDIF


      ELSEIF(isub.LE.70) THEN

        IF(isub.EQ.61) THEN

C...gamma + h0 -> f + fbar


        ELSEIF(isub.EQ.62) THEN

C...Z0 + Z0 -> f + fbar


        ELSEIF(isub.EQ.63) THEN

C...Z0 + W+/- -> f + fbar'


        ELSEIF(isub.EQ.64) THEN

C...Z0 + h0 -> f + fbar


        ELSEIF(isub.EQ.65) THEN

C...W+ + W- -> f + fbar


        ELSEIF(isub.EQ.66) THEN

C...W+/- + h0 -> f + fbar'


        ELSEIF(isub.EQ.67) THEN

C...h0 + h0 -> f + fbar


        ELSEIF(isub.EQ.68) THEN

C...g + g -> g + g; th arbitrary

          kcc=mint(2)+12

          kcs=(-1)**int(1.5d0+pyr(0))


        ELSEIF(isub.EQ.69) THEN

C...gamma + gamma -> W+ + W-; th arbitrary

          mint(21)=24

          mint(22)=-24

          kcc=21


        ELSEIF(isub.EQ.70) THEN

C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2

          IF(mint(15).EQ.22) mint(21)=23

          IF(mint(16).EQ.22) mint(22)=23

          kcc=21

        ENDIF


      ELSEIF(isub.LE.80) THEN

        IF(isub.EQ.71.OR.isub.EQ.72) THEN

C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-

          xh=sh/shp

          mint(21)=mint(15)

          mint(22)=mint(16)

          pmq(1)=pymass(mint(21))

          pmq(2)=pymass(mint(22))

  330     jt=int(1.5d0+pyr(0))

          zmin=2d0*pmq(jt)/shpr

          zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/

     &    (shpr*(shpr-pmq(3-jt)))

          zmax=min(1d0-xh,zmax)

          z(jt)=zmin+(zmax-zmin)*pyr(0)

          IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.

     &    (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 330

          sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 330

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)

          cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(jt)=min(1d0,max(-1d0,cthe(jt)))

          z(3-jt)=1d0-xh/(1d0-z(jt))

          sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 330

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)

          cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))

          phir=paru(2)*pyr(0)

          cphi=cos(phir)

          ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*

     &    sqrt(1d0-cthe(2)**2)*cphi

          z1=2d0-z(jt)

          z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)

          z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp

          z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*

     &    pmq(3-jt)**2/shp))

          zmin=2d0*pmq(3-jt)/shpr

          zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))

          zmax=min(1d0-xh,zmax)

          IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 330

          kcc=22


        ELSEIF(isub.EQ.73) THEN

C...Z0 + W+/- -> Z0 + W+/-

          js=mint(2)

          xh=sh/shp

  340     jt=3-mint(2)

          i=mint(14+jt)

          ia=iabs(i)

          IF(ia.LE.10) THEN

            rvckm=vint(180+i)*pyr(0)

            DO 350 j=1,mstp(1)

              ib=2*j-1+mod(ia,2)

              ipm=(5-isign(1,i))/2

              idc=j+mdcy(ia,2)+2

              IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 350

              mint(20+jt)=isign(ib,i)

              rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

              IF(rvckm.LE.0d0) goto 360

  350       CONTINUE

          ELSE

            ib=2*((ia+1)/2)-1+mod(ia,2)

            mint(20+jt)=isign(ib,i)

          ENDIF

  360     pmq(jt)=pymass(mint(20+jt))

          mint(23-jt)=mint(17-jt)

          pmq(3-jt)=pymass(mint(23-jt))

          jt=int(1.5d0+pyr(0))

          zmin=2d0*pmq(jt)/shpr

          zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/

     &    (shpr*(shpr-pmq(3-jt)))

          zmax=min(1d0-xh,zmax)

          IF(zmin.GE.zmax) goto 340

          z(jt)=zmin+(zmax-zmin)*pyr(0)

          IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.

     &    (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 340

          sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 340

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(jt)**2)/(z(jt)*shp)

          cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(jt)=min(1d0,max(-1d0,cthe(jt)))

          z(3-jt)=1d0-xh/(1d0-z(jt))

          sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 340

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(23,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)

          cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))

          phir=paru(2)*pyr(0)

          cphi=cos(phir)

          ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*

     &    sqrt(1d0-cthe(2)**2)*cphi

          z1=2d0-z(jt)

          z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)

          z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp

          z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*

     &    pmq(3-jt)**2/shp))

          zmin=2d0*pmq(3-jt)/shpr

          zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))

          zmax=min(1d0-xh,zmax)

          IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 340

          kcc=22


        ELSEIF(isub.EQ.74) THEN

C...Z0 + h0 -> Z0 + h0


        ELSEIF(isub.EQ.75) THEN

C...W+ + W- -> gamma + gamma


        ELSEIF(isub.EQ.76.OR.isub.EQ.77) THEN

C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-

          xh=sh/shp

  370     DO 400 jt=1,2

            i=mint(14+jt)

            ia=iabs(i)

            IF(ia.LE.10) THEN

              rvckm=vint(180+i)*pyr(0)

              DO 380 j=1,mstp(1)

                ib=2*j-1+mod(ia,2)

                ipm=(5-isign(1,i))/2

                idc=j+mdcy(ia,2)+2

                IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 380

                mint(20+jt)=isign(ib,i)

                rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

                IF(rvckm.LE.0d0) goto 390

  380         CONTINUE

            ELSE

              ib=2*((ia+1)/2)-1+mod(ia,2)

              mint(20+jt)=isign(ib,i)

            ENDIF

  390       pmq(jt)=pymass(mint(20+jt))

  400     CONTINUE

          jt=int(1.5d0+pyr(0))

          zmin=2d0*pmq(jt)/shpr

          zmax=1d0-pmq(3-jt)/shpr-(sh-pmq(jt)**2)/

     &    (shpr*(shpr-pmq(3-jt)))

          zmax=min(1d0-xh,zmax)

          IF(zmin.GE.zmax) goto 370

          z(jt)=zmin+(zmax-zmin)*pyr(0)

          IF(-1d0+(1d0+xh)/(1d0-z(jt))-xh/(1d0-z(jt))**2.LT.

     &    (1d0-xh)**2/(4d0*xh)*pyr(0)) goto 370

          sqc1=1d0-4d0*pmq(jt)**2/(z(jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 370

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(24,1)**2-pmq(jt)**2)/(z(jt)*shp)

          cthe(jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(jt)=min(1d0,max(-1d0,cthe(jt)))

          z(3-jt)=1d0-xh/(1d0-z(jt))

          sqc1=1d0-4d0*pmq(3-jt)**2/(z(3-jt)**2*shp)

          IF(sqc1.LT.1.d-8) goto 370

          c1=sqrt(sqc1)

          c2=1d0+2d0*(pmas(24,1)**2-pmq(3-jt)**2)/(z(3-jt)*shp)

          cthe(3-jt)=(c2-(c2**2-c1**2)/(c2+(2d0*pyr(0)-1d0)*c1))/c1

          cthe(3-jt)=min(1d0,max(-1d0,cthe(3-jt)))

          phir=paru(2)*pyr(0)

          cphi=cos(phir)

          ang=cthe(1)*cthe(2)-sqrt(1d0-cthe(1)**2)*

     &    sqrt(1d0-cthe(2)**2)*cphi

          z1=2d0-z(jt)

          z2=ang*sqrt(z(jt)**2-4d0*pmq(jt)**2/shp)

          z3=1d0-z(jt)-xh+(pmq(1)**2+pmq(2)**2)/shp

          z(3-jt)=2d0/(z1**2-z2**2)*(z1*z3+z2*sqrt(z3**2-(z1**2-z2**2)*

     &    pmq(3-jt)**2/shp))

          zmin=2d0*pmq(3-jt)/shpr

          zmax=1d0-pmq(jt)/shpr-(sh-pmq(3-jt)**2)/(shpr*(shpr-pmq(jt)))

          zmax=min(1d0-xh,zmax)

          IF(z(3-jt).LT.zmin.OR.z(3-jt).GT.zmax) goto 370

          kcc=22


        ELSEIF(isub.EQ.78) THEN

C...W+/- + h0 -> W+/- + h0


        ELSEIF(isub.EQ.79) THEN

C...h0 + h0 -> h0 + h0


        ELSEIF(isub.EQ.80) THEN

C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2

          IF(mint(15).EQ.22) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(211,kchg(ia,1)*i)

          ib=3-ia

          mint(20+js)=isign(ib,i)

          kcc=22

        ENDIF


      ELSEIF(isub.LE.90) THEN

        IF(isub.EQ.81) THEN

C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2

          mint(21)=isign(mint(55),mint(15))

          mint(22)=-mint(21)

          kcc=4


        ELSEIF(isub.EQ.82) THEN

C...g + g -> Q + Qbar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(mint(55),kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10


        ELSEIF(isub.EQ.83) THEN

C...f + q -> f' + Q; th = (p(f) - p(f'))**2

          kfold=mint(16)

          IF(mint(2).EQ.2) kfold=mint(15)

          kfaold=iabs(kfold)

          IF(kfaold.GT.10) THEN

            kfanew=kfaold+2*mod(kfaold,2)-1

          ELSE

            rckm=vint(180+kfold)*pyr(0)

            ipm=(5-isign(1,kfold))/2

            kfanew=-mod(kfaold+1,2)

  410       kfanew=kfanew+2

            idc=mdcy(kfaold,2)+(kfanew+1)/2+2

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.ipm) THEN

              IF(mod(kfaold,2).EQ.0) rckm=rckm-

     &        vckm(kfaold/2,(kfanew+1)/2)

              IF(mod(kfaold,2).EQ.1) rckm=rckm-

     &        vckm(kfanew/2,(kfaold+1)/2)

            ENDIF

            IF(kfanew.LE.6.AND.rckm.GT.0d0) goto 410

          ENDIF

          IF(mint(2).EQ.1) THEN

            mint(21)=isign(mint(55),mint(15))

            mint(22)=isign(kfanew,mint(16))

          ELSE

            mint(21)=isign(kfanew,mint(15))

            mint(22)=isign(mint(55),mint(16))

            js=2

          ENDIF

          kcc=22


        ELSEIF(isub.EQ.84) THEN

C...g + gamma -> Q + Qbar; th arbitary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(mint(55),kcs)

          mint(22)=-mint(21)

          kcc=27

          IF(mint(16).EQ.21) kcc=28


        ELSEIF(isub.EQ.85) THEN

C...gamma + gamma -> F + Fbar; th arbitary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(mint(56),kcs)

          mint(22)=-mint(21)

          kcc=21


        ELSEIF(isub.GE.86.AND.isub.LE.89) THEN

C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g

          mint(21)=kfpr(isub,1)

          mint(22)=kfpr(isub,2)

          kcc=24

          kcs=(-1)**int(1.5d0+pyr(0))

        ENDIF


      ELSEIF(isub.LE.100) THEN

        IF(isub.EQ.95) THEN

C...Low-pT ( = energyless g + g -> g + g)

          kcc=mint(2)+12

          kcs=(-1)**int(1.5d0+pyr(0))


        ELSEIF(isub.EQ.96) THEN

C...Multiple interactions (should be reassigned to QCD process)

        ENDIF


      ELSEIF(isub.LE.110) THEN

        IF(isub.EQ.101) THEN

C...g + g -> gamma*/Z0

          kcc=21

          kfres=22


        ELSEIF(isub.EQ.102) THEN

C...g + g -> h0 (or H0, or A0)

          kcc=21

          kfres=kfhigg


        ELSEIF(isub.EQ.103) THEN

C...gamma + gamma -> h0 (or H0, or A0)

          kcc=21

          kfres=kfhigg


        ELSEIF(isub.EQ.110) THEN

C...f + fbar -> gamma + h0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=22

          mint(23-js)=kfhigg

        ENDIF


      ELSEIF(isub.LE.120) THEN

        IF(isub.EQ.111) THEN

C...f + fbar -> g + h0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=21

          mint(23-js)=25

          kcc=17+js


        ELSEIF(isub.EQ.112) THEN

C...f + g -> f + h0; th = (p(f) - p(f))**2

          IF(mint(15).EQ.21) js=2

          mint(23-js)=25

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.113) THEN

C...g + g -> g + h0; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(23-js)=25

          kcc=22+js

          kcs=(-1)**int(1.5d0+pyr(0))


        ELSEIF(isub.EQ.114) THEN

C...g + g -> gamma + gamma; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(21)=22

          mint(22)=22

          kcc=21


        ELSEIF(isub.EQ.115) THEN

C...g + g -> g + gamma; th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(23-js)=22

          kcc=22+js

          kcs=(-1)**int(1.5d0+pyr(0))


        ELSEIF(isub.EQ.116) THEN

C...g + g -> gamma + Z0


        ELSEIF(isub.EQ.117) THEN

C...g + g -> Z0 + Z0


        ELSEIF(isub.EQ.118) THEN

C...g + g -> W+ + W-

        ENDIF


      ELSEIF(isub.LE.140) THEN

        IF(isub.EQ.121) THEN

C...g + g -> Q + Qbar + h0

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kfpr(isubsv,2),kcs)

          mint(22)=-mint(21)

          kcc=11+int(0.5d0+pyr(0))

          kfres=kfhigg


        ELSEIF(isub.EQ.122) THEN

C...q + qbar -> Q + Qbar + h0

          mint(21)=isign(kfpr(isubsv,2),mint(15))

          mint(22)=-mint(21)

          kcc=4

          kfres=kfhigg


        ELSEIF(isub.EQ.123) THEN

C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as

C...inner process)

          kcc=22

          kfres=kfhigg


        ELSEIF(isub.EQ.124) THEN

C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as

C...inner process)

          DO 430 jt=1,2

            i=mint(14+jt)

            ia=iabs(i)

            IF(ia.LE.10) THEN

              rvckm=vint(180+i)*pyr(0)

              DO 420 j=1,mstp(1)

                ib=2*j-1+mod(ia,2)

                ipm=(5-isign(1,i))/2

                idc=j+mdcy(ia,2)+2

                IF(mdme(idc,1).NE.1.AND.mdme(idc,1).NE.ipm) goto 420

                mint(20+jt)=isign(ib,i)

                rvckm=rvckm-vckm((ia+1)/2,(ib+1)/2)

                IF(rvckm.LE.0d0) goto 430

  420         CONTINUE

            ELSE

              ib=2*((ia+1)/2)-1+mod(ia,2)

              mint(20+jt)=isign(ib,i)

            ENDIF

  430     CONTINUE

          kcc=22

          kfres=kfhigg


        ELSEIF(isub.EQ.131) THEN

C...g + g -> Z0 + q + qbar

        ENDIF


      ELSEIF(isub.LE.160) THEN

        IF(isub.EQ.141) THEN

C...f + fbar -> gamma*/Z0/Z'0

          kfres=32


        ELSEIF(isub.EQ.142) THEN

C...f + fbar' -> W'+/-

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          kfres=isign(34,kch1+kch2)


        ELSEIF(isub.EQ.143) THEN

C...f + fbar' -> H+/-

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          kfres=isign(37,kch1+kch2)


        ELSEIF(isub.EQ.144) THEN

C...f + fbar' -> R

          kfres=isign(40,mint(15)+mint(16))


        ELSEIF(isub.EQ.145) THEN

C...q + l -> LQ (leptoquark)

          IF(iabs(mint(16)).LE.8) js=2

          kfres=isign(39,mint(14+js))

          kcc=28+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN

C...q + g -> q* (excited quark)

          IF(mint(15).EQ.21) js=2

          kfres=isign(kfpr(isub,1),mint(14+js))

          kcc=30+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.149) THEN

C...g + g -> eta_techni

          kfres=38

          kcc=23

          kcs=(-1)**int(1.5d0+pyr(0))

        ENDIF


      ELSEIF(isub.LE.200) THEN

        IF(isub.EQ.161) THEN

C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(37,kchg(ia,1)*i)

          ib=ia+mod(ia,2)-mod(ia+1,2)

          mint(20+js)=isign(ib,i)

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.162) THEN

C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2

          IF(mint(15).EQ.21) js=2

          mint(20+js)=isign(39,mint(14+js))

          kflql=kfdp(mdcy(39,2),2)

          mint(23-js)=-isign(kflql,mint(14+js))

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.163) THEN

C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(39,kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10


        ELSEIF(isub.EQ.164) THEN

C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2

          mint(21)=isign(39,mint(15))

          mint(22)=-mint(21)

          kcc=4


        ELSEIF(isub.EQ.165) THEN

C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2

          mint(21)=isign(kfpr(isub,1),mint(15))

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.166) THEN

C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2

          IF(mod(mint(15),2).EQ.0) THEN

            mint(21)=isign(kfpr(isub,1)+1,mint(15))

            mint(22)=isign(kfpr(isub,1),mint(16))

          ELSE

            mint(21)=isign(kfpr(isub,1),mint(15))

            mint(22)=isign(kfpr(isub,1)+1,mint(16))

          ENDIF


        ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN

C...q + q' -> q" + q* (excited quark)

          kfqstr=kfpr(isub,2)

          kfqexc=mod(kfqstr,kexcit)

          js=mint(2)

          mint(20+js)=isign(kfqstr,mint(14+js))

          IF(iabs(mint(15)).NE.kfqexc.AND.iabs(mint(16)).NE.kfqexc)

     &    mint(23-js)=isign(kfqexc,mint(17-js))

          kcc=22


        ELSEIF(isub.EQ.191) THEN

C...f + fbar -> rho_tech0.

          kfres=54


        ELSEIF(isub.EQ.192) THEN

C...f + fbar' -> rho_tech+/-

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          kfres=isign(55,kch1+kch2)


        ELSEIF(isub.EQ.193) THEN

C...f + fbar -> omega_tech0.

          kfres=56


        ELSEIF(isub.EQ.194) THEN

C...f + fbar -> f' + fbar' via mixture of s-channel

C...rho_tech and omega_tech; th=(p(f)-p(f'))**2

          mint(21)=isign(kfpr(isub,1),mint(15))

          mint(22)=-mint(21)

         ENDIF


CMRENNA++

      ELSEIF(isub.LE.215) THEN

        IF(isub.EQ.201) THEN

C...f + fbar -> ~e_L + ~e_Lbar

          mint(21)=isign(ksusy1+11,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.202) THEN

C...f + fbar -> ~e_R + ~e_Rbar

          mint(21)=isign(ksusy2+11,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.203) THEN

C...f + fbar -> ~e_R + ~e_Lbar

          kcs=1

          IF(mint(2).EQ.2) kcs=-1

          mint(21)=isign(ksusy1+11,kcs)

          mint(22)=-isign(ksusy2+11,kcs)


        ELSEIF(isub.EQ.204) THEN

C...f + fbar -> ~mu_L + ~mu_Lbar

          mint(21)=isign(ksusy1+13,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.205) THEN

C...f + fbar -> ~mu_R + ~mu_Rbar

          mint(21)=isign(ksusy2+13,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.206) THEN

C...f + fbar -> ~mu_L + ~mu_Rbar

          kcs=1

          IF(mint(2).EQ.2) kcs=-1

          mint(21)=isign(ksusy1+13,kcs)

          mint(22)=-isign(ksusy2+13,kcs)


        ELSEIF(isub.EQ.207) THEN

C...f + fbar -> ~tau_1 + ~tau_1bar

          mint(21)=isign(ksusy1+15,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.208) THEN

C...f + fbar -> ~tau_2 + ~tau_2bar

          mint(21)=isign(ksusy2+15,kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.209) THEN

C...f + fbar -> ~tau_1 + ~tau_2bar

          kcs=1

          IF(mint(2).EQ.2) kcs=-1

          mint(21)=isign(ksusy1+15,kcs)

          mint(22)=-isign(ksusy2+15,kcs)


        ELSEIF(isub.EQ.210) THEN

C...q + qbar' -> ~l_L + ~nulbar; th arbitrary

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          mint(21)=-isign(kfpr(isub,1),kch1+kch2)

          mint(22)=isign(kfpr(isub,2),kch1+kch2)


        ELSEIF(isub.EQ.211) THEN

C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          mint(21)=-isign(ksusy1+15,kch1+kch2)

          mint(22)=isign(ksusy1+16,kch1+kch2)


        ELSEIF(isub.EQ.212) THEN

C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          mint(21)=-isign(ksusy2+15,kch1+kch2)

          mint(22)=isign(ksusy1+16,kch1+kch2)


        ELSEIF(isub.EQ.213) THEN

C...f + fbar -> ~nul + ~nulbar

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.214) THEN

C...f + fbar -> ~nutau + ~nutaubar

          mint(21)=isign(ksusy1+16,kcs)

          mint(22)=-mint(21)

        ENDIF


      ELSEIF(isub.LE.225) THEN

        IF(isub.EQ.216) THEN

C...f + fbar -> ~chi01 + ~chi01

          mint(21)=ksusy1+22

          mint(22)=ksusy1+22


        ELSEIF(isub.EQ.217) THEN

C...f + fbar -> ~chi02 + ~chi02

          mint(21)=ksusy1+23

          mint(22)=ksusy1+23


        ELSEIF(isub.EQ.218 ) THEN

C...f + fbar -> ~chi03 + ~chi03

          mint(21)=ksusy1+25

          mint(22)=ksusy1+25


        ELSEIF(isub.EQ.219 ) THEN

C...f + fbar -> ~chi04 + ~chi04

          mint(21)=ksusy1+35

          mint(22)=ksusy1+35


        ELSEIF(isub.EQ.220 ) THEN

C...f + fbar -> ~chi01 + ~chi02

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+22

          mint(23-js)=ksusy1+23


        ELSEIF(isub.EQ.221 ) THEN

C...f + fbar -> ~chi01 + ~chi03

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+22

          mint(23-js)=ksusy1+25


        ELSEIF(isub.EQ.222) THEN

C...f + fbar -> ~chi01 + ~chi04

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+22

          mint(23-js)=ksusy1+35


        ELSEIF(isub.EQ.223) THEN

C...f + fbar -> ~chi02 + ~chi03

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+23

          mint(23-js)=ksusy1+25


        ELSEIF(isub.EQ.224) THEN

C...f + fbar -> ~chi02 + ~chi04

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+23

          mint(23-js)=ksusy1+35


        ELSEIF(isub.EQ.225) THEN

C...f + fbar -> ~chi03 + ~chi04

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+25

          mint(23-js)=ksusy1+35

        ENDIF


      ELSEIF(isub.LE.236) THEN

        IF(isub.EQ.226) THEN

C...f + fbar -> ~chi+-1 + ~chi-+1

C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2

          mint(21)=isign(ksusy1+24,mint(15))

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.227) THEN

C...f + fbar -> ~chi+-2 + ~chi-+2

          mint(21)=isign(ksusy1+37,mint(15))

          mint(22)=-mint(21)


        ELSEIF(isub.EQ.228) THEN

C...f + fbar -> ~chi+-1 + ~chi-+2

C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2

C...js=1 if pyr<.5, js=2 if pyr>.5

C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2

C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2

C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2

C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2

          kch1=isign(1,mint(15))

          kch2=int(1-kch1)/2

          IF(mint(2).EQ.1) THEN

            mint(22-kch2)= -(ksusy1+24)

            mint(21+kch2)= ksusy1+37

            IF(kch2.EQ.0) js=2

          ELSE

            mint(21+kch2)= ksusy1+24

            mint(22-kch2)= -(ksusy1+37)

            IF(kch2.EQ.1) js=2

          ENDIF


        ELSEIF(isub.EQ.229) THEN

C...q + qbar' -> ~chi01 + ~chi+-1

C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

C...CHECK THIS

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+22

          mint(23-js)=isign(ksusy1+24,kch1+kch2)


        ELSEIF(isub.EQ.230) THEN

C...q + qbar' -> ~chi02 + ~chi+-1

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+23

          mint(23-js)=isign(ksusy1+24,kch1+kch2)


        ELSEIF(isub.EQ.231) THEN

C...q + qbar' -> ~chi03 + ~chi+-1

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+25

          mint(23-js)=isign(ksusy1+24,kch1+kch2)


        ELSEIF(isub.EQ.232) THEN

C...q + qbar' -> ~chi04 + ~chi+-1

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+35

          mint(23-js)=isign(ksusy1+24,kch1+kch2)


        ELSEIF(isub.EQ.233) THEN

C...q + qbar' -> ~chi01 + ~chi+-2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+22

          mint(23-js)=isign(ksusy1+37,kch1+kch2)


        ELSEIF(isub.EQ.234) THEN

C...q + qbar' -> ~chi02 + ~chi+-2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+23

          mint(23-js)=isign(ksusy1+37,kch1+kch2)


        ELSEIF(isub.EQ.235) THEN

C...q + qbar' -> ~chi03 + ~chi+-2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+25

          mint(23-js)=isign(ksusy1+37,kch1+kch2)


        ELSEIF(isub.EQ.236) THEN

C...q + qbar' -> ~chi04 + ~chi+-2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          IF(mod(mint(15),2).NE.0) js=2

          mint(20+js)=ksusy1+35

          mint(23-js)=isign(ksusy1+37,kch1+kch2)

        ENDIF


      ELSEIF(isub.LE.245) THEN

        IF(isub.EQ.237) THEN

C...q + qbar -> ~chi01 + ~g

C...th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=ksusy1+22

          kcc=17+js


        ELSEIF(isub.EQ.238) THEN

C...q + qbar -> ~chi02 + ~g

C...th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=ksusy1+23

          kcc=17+js


        ELSEIF(isub.EQ.239) THEN

C...q + qbar -> ~chi03 + ~g

C...th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=ksusy1+25

          kcc=17+js


        ELSEIF(isub.EQ.240) THEN

C...q + qbar -> ~chi04 + ~g

C...th arbitrary

          IF(pyr(0).GT.0.5d0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=ksusy1+35

          kcc=17+js


        ELSEIF(isub.EQ.241) THEN

C...q + qbar' -> ~chi+-1 + ~g

C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+

C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-

C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-

C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+

C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          js=1

          IF(mint(15)*(kch1+kch2).GT.0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=isign(ksusy1+24,kch1+kch2)

          kcc=17+js


        ELSEIF(isub.EQ.242) THEN

C...q + qbar' -> ~chi+-2 + ~g

C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+

C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-

C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-

C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+

C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2

          kch1=kchg(iabs(mint(15)),1)*isign(1,mint(15))

          kch2=kchg(iabs(mint(16)),1)*isign(1,mint(16))

          js=1

          IF(mint(15)*(kch1+kch2).GT.0) js=2

          mint(20+js)=ksusy1+21

          mint(23-js)=isign(ksusy1+37,kch1+kch2)

          kcc=17+js


        ELSEIF(isub.EQ.243) THEN

C...q + qbar -> ~g + ~g ; th arbitrary

          mint(21)=ksusy1+21

          mint(22)=ksusy1+21

          kcc=mint(2)+4


        ELSEIF(isub.EQ.244) THEN

C...g + g -> ~g + ~g ; th arbitrary

          kcc=mint(2)+12

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=ksusy1+21

          mint(22)=ksusy1+21

        ENDIF


      ELSEIF(isub.LE.260) THEN

        IF(isub.EQ.246) THEN

C...qj + g -> ~qj_L + ~chi01

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy1+ia,i)

          mint(23-js)=ksusy1+22

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.247) THEN

C...qj + g -> ~qj_R + ~chi01

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy2+ia,i)

          mint(23-js)=ksusy1+22

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.248) THEN

C...qj + g -> ~qj_L + ~chi02

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy1+ia,i)

          mint(23-js)=ksusy1+23

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.249) THEN

C...qj + g -> ~qj_R + ~chi02

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy2+ia,i)

          mint(23-js)=ksusy1+23

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.250) THEN

C...qj + g -> ~qj_L + ~chi03

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy1+ia,i)

          mint(23-js)=ksusy1+25

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.251) THEN

C...qj + g -> ~qj_R + ~chi03

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy2+ia,i)

          mint(23-js)=ksusy1+25

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.252) THEN

C...qj + g -> ~qj_L + ~chi04

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy1+ia,i)

          mint(23-js)=ksusy1+35

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.253) THEN

C...qj + g -> ~qj_R + ~chi04

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy2+ia,i)

          mint(23-js)=ksusy1+35

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.254) THEN

C...qj + g -> ~qk_L + ~chi+-1

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)

          ib=-ia+int((ia+1)/2)*4-1

          mint(20+js)=isign(ksusy1+ib,i)

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.255) THEN

C...qj + g -> ~qk_L + ~chi+-1

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(23-js)=isign(ksusy1+24,kchg(ia,1)*i)

          ib=-ia+int((ia+1)/2)*4-1

          mint(20+js)=isign(ksusy2+ib,i)

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.256) THEN

C...qj + g -> ~qk_L + ~chi+-2

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          ib=-ia+int((ia+1)/2)*4-1

          mint(20+js)=isign(ksusy1+ib,i)

          mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.257) THEN

C...qj + g -> ~qk_R + ~chi+-2

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          ib=-ia+int((ia+1)/2)*4-1

          mint(20+js)=isign(ksusy2+ib,i)

          mint(23-js)=isign(ksusy1+37,kchg(ia,1)*i)

          kcc=15+js

          kcs=isign(1,mint(14+js))


        ELSEIF(isub.EQ.258) THEN

C...qj + g -> ~qj_L + ~g

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy1+ia,i)

          mint(23-js)=ksusy1+21

          kcc=mint(2)+6

          IF(js.EQ.2) kcc=kcc+2

          kcs=isign(1,i)


        ELSEIF(isub.EQ.259) THEN

C...qj + g -> ~qj_R + ~g

          IF(mint(15).EQ.21) js=2

          i=mint(14+js)

          ia=iabs(i)

          mint(20+js)=isign(ksusy2+ia,i)

          mint(23-js)=ksusy1+21

          kcc=mint(2)+6

          IF(js.EQ.2) kcc=kcc+2

          kcs=isign(1,i)

        ENDIF


      ELSEIF(isub.LE.270) THEN

        IF(isub.EQ.261) THEN

C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

C...Correct color combination

          IF(mint(43).EQ.4) kcc=4


        ELSEIF(isub.EQ.262) THEN

C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

C...Correct color combination

          IF(mint(43).EQ.4) kcc=4


        ELSEIF(isub.EQ.263) THEN

C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2

          IF((kcs.GT.0.AND.mint(2).EQ.1).OR.

     &    (kcs.LT.0.AND.mint(2).EQ.2)) THEN

            mint(21)=isign(kfpr(isub,1),kcs)

            mint(22)=-isign(kfpr(isub,2),kcs)

          ELSE

            js=2

            mint(21)=isign(kfpr(isub,2),kcs)

            mint(22)=-isign(kfpr(isub,1),kcs)

          ENDIF

C...Correct color combination

          IF(mint(43).EQ.4) kcc=4


        ELSEIF(isub.EQ.264) THEN

C...g + g -> ~t_1 + ~t_1bar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10


        ELSEIF(isub.EQ.265) THEN

C...g + g -> ~t_2 + ~t_2bar; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10

        ENDIF


      ELSEIF(isub.LE.280) THEN

        IF(isub.EQ.271) THEN

C...qi + qj -> ~qi_L + ~qj_L

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2

          mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))

          mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))


        ELSEIF(isub.EQ.272) THEN

C...qi + qj -> ~qi_R + ~qj_R

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2

          mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))

          mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))


        ELSEIF(isub.EQ.273) THEN

C...qi + qj -> ~qi_L + ~qj_R

          mint(21)=isign(kfpr(isub,1),mint(15))

          mint(22)=isign(kfpr(isub,2),mint(16))

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2


        ELSEIF(isub.EQ.274) THEN

C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2

          mint(21)=isign(ksusy1+iabs(mint(15)),mint(15))

          mint(22)=isign(ksusy1+iabs(mint(16)),mint(16))

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2


        ELSEIF(isub.EQ.275) THEN

C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2

          mint(21)=isign(ksusy2+iabs(mint(15)),mint(15))

          mint(22)=isign(ksusy2+iabs(mint(16)),mint(16))

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2


        ELSEIF(isub.EQ.276) THEN

C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2

          mint(21)=isign(kfpr(isub,1),mint(15))

          mint(22)=isign(kfpr(isub,2),mint(16))

          kcc=mint(2)

          IF(mint(15)*mint(16).LT.0) kcc=kcc+2


        ELSEIF(isub.EQ.277) THEN

C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2

          isgn=1

          IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1

          mint(21)=isgn*isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          IF(mint(43).EQ.4) kcc=4


        ELSEIF(isub.EQ.278) THEN

C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2

          isgn=1

          IF(mint(43).EQ.1.AND.pyr(0).GT.0.5d0) isgn=-1

          mint(21)=isgn*isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          IF(mint(43).EQ.4) kcc=4


        ELSEIF(isub.EQ.279) THEN

C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary

C...pure LL + RR

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10


        ELSEIF(isub.EQ.280) THEN

C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary

          kcs=(-1)**int(1.5d0+pyr(0))

          mint(21)=isign(kfpr(isub,1),kcs)

          mint(22)=-mint(21)

          kcc=mint(2)+10

        ENDIF


CMRENNA--

      ENDIF


      IF(iset(isub).EQ.11) THEN

C...Store documentation for user-defined processes

        bezup=(pup(1,4)-pup(2,4))/(pup(1,4)+pup(2,4))

        kuppo(1)=mint(83)+5

        kuppo(2)=mint(83)+6

        i=mint(83)+6

        DO 450 iup=3,nup

          kuppo(iup)=0

          IF(mstp(128).GE.2.AND.kup(iup,3).NE.0) THEN

            idoc=idoc-1

            mint(4)=mint(4)-1

            goto 450

          ENDIF

          i=i+1

          kuppo(iup)=i

          k(i,1)=21

          k(i,2)=kup(iup,2)

          k(i,3)=0

          IF(kup(iup,3).NE.0) k(i,3)=kuppo(kup(iup,3))

          k(i,4)=0

          k(i,5)=0

          DO 440 j=1,5

            p(i,j)=pup(iup,j)

  440     CONTINUE

  450   CONTINUE

        CALL pyrobo(mint(83)+7,mint(83)+4+nup,0d0,vint(24),0d0,0d0,

     &  -bezup)


C...Store final state partons for user-defined processes

        n=ipu2

        DO 470 iup=3,nup

          n=n+1

          k(n,1)=1

          IF(kup(iup,1).NE.1) k(n,1)=11

          k(n,2)=kup(iup,2)

          IF(mstp(128).LE.0.OR.kup(iup,3).EQ.0) THEN

            k(n,3)=kuppo(iup)

          ELSE

            k(n,3)=mint(84)+kup(iup,3)

          ENDIF

          k(n,4)=0

          k(n,5)=0

          DO 460 j=1,5

            p(n,j)=pup(iup,j)

  460     CONTINUE

  470   CONTINUE

        CALL pyrobo(ipu3,n,0d0,vint(24),0d0,0d0,-bezup)


C...Arrange colour flow for user-defined processes

        n=mint(84)

        DO 480 iup=1,nup

          n=n+1

          IF(kchg(pycomp(k(n,2)),2).EQ.0) goto 480

          IF(k(n,1).EQ.1) k(n,1)=3

          IF(k(n,1).EQ.11) k(n,1)=14

          IF(kup(iup,4).NE.0) k(n,4)=k(n,4)+mstu(5)*(kup(iup,4)+

     &    mint(84))

          IF(kup(iup,5).NE.0) k(n,5)=k(n,5)+mstu(5)*(kup(iup,5)+

     &    mint(84))

          IF(kup(iup,6).NE.0) k(n,4)=k(n,4)+kup(iup,6)+mint(84)

          IF(kup(iup,7).NE.0) k(n,5)=k(n,5)+kup(iup,7)+mint(84)

  480   CONTINUE


      ELSEIF(idoc.EQ.7) THEN

C...Resonance not decaying; store kinematics

        i=mint(83)+7

        k(ipu3,1)=1

        k(ipu3,2)=kfres

        k(ipu3,3)=i

        p(ipu3,4)=shuser

        p(ipu3,5)=shuser

        k(i,1)=21

        k(i,2)=kfres

        p(i,4)=shuser

        p(i,5)=shuser

        n=ipu3

        mint(21)=kfres

        mint(22)=0


C...Special cases: colour flow in coloured resonances

        kcres=pycomp(kfres)

        IF(kchg(kcres,2).NE.0) THEN

          k(ipu3,1)=3

          DO 490 j=1,2

            jc=j

            IF(kcs.EQ.-1) jc=3-j

            IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=

     &      mint(84)+icol(kcc,1,jc)

            IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=

     &      mint(84)+icol(kcc,2,jc)

            IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=

     &      mstu(5)*(mint(84)+icol(kcc,3,jc))

  490     CONTINUE

        ELSE

          k(ipu1,4)=ipu2

          k(ipu1,5)=ipu2

          k(ipu2,4)=ipu1

          k(ipu2,5)=ipu1

        ENDIF


      ELSEIF(idoc.EQ.8) THEN

C...2 -> 2 processes: store outgoing partons in their CM-frame

        DO 500 jt=1,2

          i=mint(84)+2+jt

          kca=pycomp(mint(20+jt))

          k(i,1)=1

          IF(kchg(kca,2).NE.0) k(i,1)=3

          k(i,2)=mint(20+jt)

          k(i,3)=mint(83)+idoc+jt-2

          kfaa=iabs(k(i,2))

          IF(mwid(kca).NE.0.AND.kfpr(isubsv,1).NE.0) THEN

            p(i,5)=sqrt(vint(63+mod(js+jt,2)))

          ELSEIF(mwid(kca).NE.0.AND.kfpr(isubsv,2).NE.0) THEN

            p(i,5)=sqrt(vint(64))

          ELSE

            p(i,5)=pymass(k(i,2))

          ENDIF

          IF((kfaa.EQ.6.OR.kfaa.EQ.7.OR.kfaa.EQ.8).AND.

     &    p(i,5).LT.parp(42)) p(i,5)=pymass(k(i,2))

  500   CONTINUE

        IF(p(ipu3,5)+p(ipu4,5).GE.shr) THEN

          kfa1=iabs(mint(21))

          kfa2=iabs(mint(22))

          IF((kfa1.GT.3.AND.kfa1.NE.21).OR.(kfa2.GT.3.AND.kfa2.NE.21))

     &    THEN

            mint(51)=1

            RETURN

          ENDIF

          p(ipu3,5)=0d0

          p(ipu4,5)=0d0

        ENDIF

        p(ipu3,4)=0.5d0*(shr+(p(ipu3,5)**2-p(ipu4,5)**2)/shr)

        p(ipu3,3)=sqrt(max(0d0,p(ipu3,4)**2-p(ipu3,5)**2))

        p(ipu4,4)=shr-p(ipu3,4)

        p(ipu4,3)=-p(ipu3,3)

        n=ipu4

        mint(7)=mint(83)+7

        mint(8)=mint(83)+8


C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)

        CALL pyrobo(ipu3,ipu4,acos(vint(23)),vint(24),0d0,0d0,0d0)


      ELSEIF(idoc.EQ.9) THEN

C...2 -> 3 processes: store outgoing partons in their CM frame

        DO 510 jt=1,2

          i=mint(84)+2+jt

          kca=pycomp(mint(20+jt))

          k(i,1)=1

          IF(kchg(kca,2).NE.0) k(i,1)=3

          k(i,2)=mint(20+jt)

          k(i,3)=mint(83)+idoc+jt-3

          IF(iabs(k(i,2)).LE.22) THEN

            p(i,5)=pymass(k(i,2))

          ELSE

            p(i,5)=sqrt(vint(63+mod(js+jt,2)))

          ENDIF

          pt=sqrt(max(0d0,vint(197+5*jt)-p(i,5)**2+vint(196+5*jt)**2))

          p(i,1)=pt*cos(vint(198+5*jt))

          p(i,2)=pt*sin(vint(198+5*jt))

  510   CONTINUE

        k(ipu5,1)=1

        k(ipu5,2)=kfres

        k(ipu5,3)=mint(83)+idoc

        p(ipu5,5)=shr

        p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)

        p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)

        pms1=p(ipu3,5)**2+p(ipu3,1)**2+p(ipu3,2)**2

        pms2=p(ipu4,5)**2+p(ipu4,1)**2+p(ipu4,2)**2

        pms3=p(ipu5,5)**2+p(ipu5,1)**2+p(ipu5,2)**2

        pmt3=sqrt(pms3)

        p(ipu5,3)=pmt3*sinh(vint(211))

        p(ipu5,4)=pmt3*cosh(vint(211))

        pms12=(shpr-p(ipu5,4))**2-p(ipu5,3)**2

        sql12=(pms12-pms1-pms2)**2-4d0*pms1*pms2

        IF(sql12.LE.0d0) THEN

          mint(51)=1

          RETURN

        ENDIF

        p(ipu3,3)=(-p(ipu5,3)*(pms12+pms1-pms2)+

     &  vint(213)*(shpr-p(ipu5,4))*sqrt(sql12))/(2d0*pms12)

        p(ipu4,3)=-p(ipu3,3)-p(ipu5,3)

        p(ipu3,4)=sqrt(pms1+p(ipu3,3)**2)

        p(ipu4,4)=sqrt(pms2+p(ipu4,3)**2)

        mint(23)=kfres

        n=ipu5

        mint(7)=mint(83)+7

        mint(8)=mint(83)+8


      ELSEIF(idoc.EQ.11) THEN

C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons

        phi(1)=paru(2)*pyr(0)

        phi(2)=phi(1)-phir

        DO 520 jt=1,2

          i=mint(84)+2+jt

          k(i,1)=1

          IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3

          k(i,2)=mint(20+jt)

          k(i,3)=mint(83)+idoc+jt-2

          p(i,5)=pymass(k(i,2))

          IF(0.5d0*shpr*z(jt).LE.p(i,5)) THEN

            mint(51)=1

            RETURN

          ENDIF

          pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))

          ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))

          p(i,1)=ptabs*cos(phi(jt))

          p(i,2)=ptabs*sin(phi(jt))

          p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)

          p(i,4)=0.5d0*shpr*z(jt)

          izw=mint(83)+6+jt

          k(izw,1)=21

          k(izw,2)=23

          IF(isub.EQ.8) k(izw,2)=isign(24,pychge(mint(14+jt)))

          k(izw,3)=izw-2

          p(izw,1)=-p(i,1)

          p(izw,2)=-p(i,2)

          p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)

          p(izw,4)=0.5d0*shpr*(1d0-z(jt))

          p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))

  520   CONTINUE

        i=mint(83)+9

        k(ipu5,1)=1

        k(ipu5,2)=kfres

        k(ipu5,3)=i

        p(ipu5,5)=shr

        p(ipu5,1)=-p(ipu3,1)-p(ipu4,1)

        p(ipu5,2)=-p(ipu3,2)-p(ipu4,2)

        p(ipu5,3)=-p(ipu3,3)-p(ipu4,3)

        p(ipu5,4)=shpr-p(ipu3,4)-p(ipu4,4)

        k(i,1)=21

        k(i,2)=kfres

        DO 530 j=1,5

          p(i,j)=p(ipu5,j)

  530   CONTINUE

        n=ipu5

        mint(23)=kfres


      ELSEIF(idoc.EQ.12) THEN

C...Z0 and W+/- scattering: store bosons and outgoing partons

        phi(1)=paru(2)*pyr(0)

        phi(2)=phi(1)-phir

        jtran=int(1.5d0+pyr(0))

        DO 540 jt=1,2

          i=mint(84)+2+jt

          k(i,1)=1

          IF(kchg(pycomp(mint(20+jt)),2).NE.0) k(i,1)=3

          k(i,2)=mint(20+jt)

          k(i,3)=mint(83)+idoc+jt-2

          p(i,5)=pymass(k(i,2))

          IF(0.5d0*shpr*z(jt).LE.p(i,5)) p(i,5)=0d0

          pabs=sqrt(max(0d0,(0.5d0*shpr*z(jt))**2-p(i,5)**2))

          ptabs=pabs*sqrt(max(0d0,1d0-cthe(jt)**2))

          p(i,1)=ptabs*cos(phi(jt))

          p(i,2)=ptabs*sin(phi(jt))

          p(i,3)=pabs*cthe(jt)*(-1)**(jt+1)

          p(i,4)=0.5d0*shpr*z(jt)

          izw=mint(83)+6+jt

          k(izw,1)=21

          IF(mint(14+jt).EQ.mint(20+jt)) THEN

            k(izw,2)=23

          ELSE

            k(izw,2)=isign(24,pychge(mint(14+jt))-pychge(mint(20+jt)))

          ENDIF

          k(izw,3)=izw-2

          p(izw,1)=-p(i,1)

          p(izw,2)=-p(i,2)

          p(izw,3)=(0.5d0*shpr-pabs*cthe(jt))*(-1)**(jt+1)

          p(izw,4)=0.5d0*shpr*(1d0-z(jt))

          p(izw,5)=-sqrt(max(0d0,p(izw,3)**2+ptabs**2-p(izw,4)**2))

          ipu=mint(84)+4+jt

          k(ipu,1)=3

          k(ipu,2)=kfpr(isub,jt)

          IF(isub.EQ.72.AND.jt.EQ.jtran) k(ipu,2)=-k(ipu,2)

          IF(isub.EQ.73.OR.isub.EQ.77) k(ipu,2)=k(izw,2)

          k(ipu,3)=mint(83)+8+jt

          IF(iabs(k(ipu,2)).LE.10.OR.k(ipu,2).EQ.21) THEN

            p(ipu,5)=pymass(k(ipu,2))

          ELSE

            p(ipu,5)=sqrt(vint(63+mod(js+jt,2)))

          ENDIF

          mint(22+jt)=k(ipu,2)

  540   CONTINUE

C...Find rotation and boost for hard scattering subsystem

        i1=mint(83)+7

        i2=mint(83)+8

        bexcm=(p(i1,1)+p(i2,1))/(p(i1,4)+p(i2,4))

        beycm=(p(i1,2)+p(i2,2))/(p(i1,4)+p(i2,4))

        bezcm=(p(i1,3)+p(i2,3))/(p(i1,4)+p(i2,4))

        gamcm=(p(i1,4)+p(i2,4))/shr

        bepcm=bexcm*p(i1,1)+beycm*p(i1,2)+bezcm*p(i1,3)

        px=p(i1,1)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bexcm

        py=p(i1,2)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*beycm

        pz=p(i1,3)+gamcm*(gamcm/(1d0+gamcm)*bepcm-p(i1,4))*bezcm

        thecm=pyangl(pz,sqrt(px**2+py**2))

        phicm=pyangl(px,py)

C...Store hard scattering subsystem. Rotate and boost it

        sqlam=(sh-p(ipu5,5)**2-p(ipu6,5)**2)**2-4d0*p(ipu5,5)**2*

     &  p(ipu6,5)**2

        pabs=sqrt(max(0d0,sqlam/(4d0*sh)))

        cthwz=vint(23)

        sthwz=sqrt(max(0d0,1d0-cthwz**2))

        phiwz=vint(24)-phicm

        p(ipu5,1)=pabs*sthwz*cos(phiwz)

        p(ipu5,2)=pabs*sthwz*sin(phiwz)

        p(ipu5,3)=pabs*cthwz

        p(ipu5,4)=sqrt(pabs**2+p(ipu5,5)**2)

        p(ipu6,1)=-p(ipu5,1)

        p(ipu6,2)=-p(ipu5,2)

        p(ipu6,3)=-p(ipu5,3)

        p(ipu6,4)=sqrt(pabs**2+p(ipu6,5)**2)

        CALL pyrobo(ipu5,ipu6,thecm,phicm,bexcm,beycm,bezcm)

        DO 560 jt=1,2

          i1=mint(83)+8+jt

          i2=mint(84)+4+jt

          k(i1,1)=21

          k(i1,2)=k(i2,2)

          DO 550 j=1,5

            p(i1,j)=p(i2,j)

  550     CONTINUE

  560   CONTINUE

        n=ipu6

        mint(7)=mint(83)+9

        mint(8)=mint(83)+10

      ENDIF


      IF(iset(isub).EQ.11) THEN

      ELSEIF(idoc.GE.8) THEN

C...Store colour connection indices

        DO 570 j=1,2

          jc=j

          IF(kcs.EQ.-1) jc=3-j

          IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=

     &    k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)

          IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=

     &    k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)

          IF(icol(kcc,3,jc).NE.0.AND.k(ipu3,1).EQ.3) k(ipu3,j+3)=

     &    mstu(5)*(mint(84)+icol(kcc,3,jc))

          IF(icol(kcc,4,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=

     &    mstu(5)*(mint(84)+icol(kcc,4,jc))

  570   CONTINUE


C...Copy outgoing partons to documentation lines

        imax=2

        IF(idoc.EQ.9) imax=3

        DO 590 i=1,imax

          i1=mint(83)+idoc-imax+i

          i2=mint(84)+2+i

          k(i1,1)=21

          k(i1,2)=k(i2,2)

          IF(idoc.LE.9) k(i1,3)=0

          IF(idoc.GE.11) k(i1,3)=mint(83)+2+i

          DO 580 j=1,5

            p(i1,j)=p(i2,j)

  580     CONTINUE

  590   CONTINUE


      ELSEIF(idoc.EQ.9) THEN

C...Store colour connection indices

        DO 600 j=1,2

          jc=j

          IF(kcs.EQ.-1) jc=3-j

          IF(icol(kcc,1,jc).NE.0.AND.k(ipu1,1).EQ.14) k(ipu1,j+3)=

     &    k(ipu1,j+3)+mint(84)+icol(kcc,1,jc)+

     &    max(0,min(1,icol(kcc,1,jc)-2))

          IF(icol(kcc,2,jc).NE.0.AND.k(ipu2,1).EQ.14) k(ipu2,j+3)=

     &    k(ipu2,j+3)+mint(84)+icol(kcc,2,jc)+

     &    max(0,min(1,icol(kcc,2,jc)-2))

          IF(icol(kcc,3,jc).NE.0.AND.k(ipu4,1).EQ.3) k(ipu4,j+3)=

     &    mstu(5)*(mint(84)+icol(kcc,3,jc))

          IF(icol(kcc,4,jc).NE.0.AND.k(ipu5,1).EQ.3) k(ipu5,j+3)=

     &    mstu(5)*(mint(84)+icol(kcc,4,jc))

  600   CONTINUE


C...Copy outgoing partons to documentation lines

        DO 620 i=1,3

          i1=mint(83)+idoc-3+i

          i2=mint(84)+2+i

          k(i1,1)=21

          k(i1,2)=k(i2,2)

          k(i1,3)=0

          DO 610 j=1,5

            p(i1,j)=p(i2,j)

  610     CONTINUE

  620   CONTINUE

      ENDIF


C...Low-pT events: remove gluons used for string drawing purposes

      IF(isub.EQ.95) THEN

        k(ipu3,1)=k(ipu3,1)+10

        k(ipu4,1)=k(ipu4,1)+10

        DO 630 j=41,66

          vintsv(j)=vint(j)

          vint(j)=0d0

  630   CONTINUE

        DO 650 i=mint(83)+5,mint(83)+8

          DO 640 j=1,5

            p(i,j)=0d0

  640     CONTINUE

  650   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYSSPA

C...Generates spacelike parton showers.


      SUBROUTINE pysspa(IPU1,IPU2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint3/

C...Local arrays and data.

      dimension kfls(4),is(2),xs(2),zs(2),q2s(2),tevcsv(2),tevesv(2),

     &xfs(2,-25:25),xfa(-25:25),xfb(-25:25),xfn(-25:25),wtapc(-25:25),

     &wtape(-25:25),wtsf(-25:25),the2(2),alam(2),dq2(3),dpc(3),dpd(4),

     &dpb(4),robo(5),more(2),kfbeam(2),q2mncs(2),kcfi(2),nfis(2),

     &thefis(2,2),isfi(2)

      DATA is/2*0/


C...Read out basic information; set global Q^2 scale.

      ipus1=ipu1

      ipus2=ipu2

      isub=mint(1)

      q2mx=vint(56)

      IF(iset(isub).EQ.2) q2mx=parp(67)*vint(56)


C...Initialize QCD evolution and check phase space.

      q2mnc=parp(62)**2

      q2mncs(1)=q2mnc

      IF(mstp(66).EQ.1.AND.mint(107).EQ.3)

     &q2mncs(1)=max(q2mnc,vint(283))

      q2mncs(2)=q2mnc

      IF(mstp(66).EQ.1.AND.mint(108).EQ.3)

     &q2mncs(2)=max(q2mnc,vint(284))

      mcev=0

      xec0=2d0*parp(65)/vint(1)

      alams=paru(112)

      paru(112)=parp(61)

      fq2c=1d0

      tcmx=0d0

      IF(mint(47).GE.2.AND.(mint(47).NE.5.OR.mstp(12).GE.1)) THEN

        mcev=1

        IF(mstp(64).EQ.1) fq2c=parp(63)

        IF(mstp(64).EQ.2) fq2c=parp(64)

        tcmx=log(fq2c*q2mx/parp(61)**2)

        IF(q2mx.LT.max(q2mnc,2d0*parp(61)**2).OR.tcmx.LT.0.2d0)

     &  mcev=0

      ENDIF


C...Initialize QED evolution and check phase space.

      q2mne=parp(68)**2

      meev=0

      xee=1d-6

      spme=pmas(11,1)**2

      temx=0d0

      fwte=10d0

      IF(mint(45).EQ.3.OR.mint(46).EQ.3) THEN

        meev=1

        temx=log(q2mx/spme)

        IF(q2mx.LE.q2mne.OR.temx.LT.0.2d0) meev=0

      ENDIF

      IF(mcev.EQ.0.AND.meev.EQ.0) RETURN


C...Initial values: flavours, momenta, virtualities.

      ns=n

  100 n=ns

      DO 120 jt=1,2

        more(jt)=1

        kfbeam(jt)=mint(10+jt)

        IF(mint(18+jt).EQ.1)kfbeam(jt)=22

        kfls(jt)=mint(14+jt)

        kfls(jt+2)=kfls(jt)

        xs(jt)=vint(40+jt)

        IF(mint(18+jt).EQ.1) xs(jt)=vint(40+jt)/vint(154+jt)

        zs(jt)=1d0

        q2s(jt)=q2mx

        tevcsv(jt)=tcmx

        alam(jt)=parp(61)

        the2(jt)=100d0

        tevesv(jt)=temx

        DO 110 kfl=-25,25

          xfs(jt,kfl)=xsfx(jt,kfl)

  110   CONTINUE

  120 CONTINUE

      dsh=vint(44)

      IF(iset(isub).GE.3.AND.iset(isub).LE.5) dsh=vint(26)*vint(2)


C...Find if interference with final state partons.

      mfis=0

      IF(mstp(67).GE.1.AND.mstp(67).LE.3) mfis=mstp(67)

      IF(mfis.NE.0) THEN

        DO 140 i=1,2

          kcfi(i)=0

          kca=pycomp(iabs(kfls(i)))

          IF(kca.NE.0) kcfi(i)=kchg(kca,2)*isign(1,kfls(i))

          nfis(i)=0

          IF(kcfi(i).NE.0) THEN

            IF(i.EQ.1) ipfs=ipus1

            IF(i.EQ.2) ipfs=ipus2

            DO 130 j=1,2

              icsi=mod(k(ipfs,3+j),mstu(5))

              IF(icsi.GT.0.AND.icsi.NE.ipus1.AND.icsi.NE.ipus2.AND.

     &        (kcfi(i).EQ.(-1)**(j+1).OR.kcfi(i).EQ.2)) THEN

                nfis(i)=nfis(i)+1

                thefis(i,nfis(i))=pyangl(p(icsi,3),sqrt(p(icsi,1)**2+

     &          p(icsi,2)**2))

                IF(i.EQ.2) thefis(i,nfis(i))=paru(1)-thefis(i,nfis(i))

              ENDIF

  130       CONTINUE

          ENDIF

  140   CONTINUE

        IF(nfis(1)+nfis(2).EQ.0) mfis=0

      ENDIF


C...Pick up leg with highest virtuality.

  150 n=n+1

      jt=1

      IF(n.GT.ns+1.AND.q2s(2).GT.q2s(1)) jt=2

      IF(more(jt).EQ.0) jt=3-jt

      kflb=kfls(jt)

      xb=xs(jt)

      DO 160 kfl=-25,25

        xfb(kfl)=xfs(jt,kfl)

  160 CONTINUE

      dshr=2d0*sqrt(dsh)

      dshz=dsh/zs(jt)


C...Check if allowed to branch.

      mcev=0

      IF(iabs(kflb).LE.10.OR.kflb.EQ.21) THEN

        mcev=1

        xec=max(xec0,xb*(1d0/(1d0-parp(66))-1d0))

        IF(xb.GE.1d0-2d0*xec) mcev=0

      ENDIF

      meev=0

      IF(mint(44+jt).EQ.3) THEN

        meev=1

        IF(xb.GE.1d0-2d0*xee) meev=0

        IF((iabs(kflb).LE.10.OR.kflb.EQ.21).AND.xb.GE.1d0-2d0*xec)

     &  meev=0

C***Currently kill QED shower for resolved photoproduction.

        IF(mint(18+jt).EQ.1) meev=0

C***Currently kill shower for W inside electron.

        IF(iabs(kflb).EQ.24) THEN

          mcev=0

          meev=0

        ENDIF

      ENDIF

      IF(mcev.EQ.0.AND.meev.EQ.0) THEN

        q2b=0d0

        goto 250

      ENDIF


C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.

      q2b=q2s(jt)

      tevcb=tevcsv(jt)

      teveb=tevesv(jt)

      IF(mstp(62).LE.1) THEN

        IF(zs(jt).GT.0.99999d0) THEN

          q2b=q2s(jt)

        ELSE

          q2b=0.5d0*(1d0/zs(jt)+1d0)*q2s(jt)+0.5d0*(1d0/zs(jt)-1d0)*

     &    (q2s(3-jt)-dsh+sqrt((dsh+q2s(1)+q2s(2))**2+

     &    8d0*q2s(1)*q2s(2)*zs(jt)/(1d0-zs(jt))))

        ENDIF

        IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)

        IF(meev.EQ.1) teveb=log(q2b/spme)

      ENDIF

      IF(mcev.EQ.1) THEN

        alsdum=pyalps(fq2c*q2b)

        tevcb=tevcb+2d0*log(alam(jt)/paru(117))

        alam(jt)=paru(117)

        b0=(33d0-2d0*mstu(118))/6d0

      ENDIF

      tevcbs=tevcb

      tevebs=teveb


C...Select side for interference with final state partons.

      IF(mfis.GE.1.AND.n.LE.ns+2) THEN

        ifi=n-ns

        isfi(ifi)=0

        IF(iabs(kcfi(ifi)).EQ.1.AND.nfis(ifi).EQ.1) THEN

          isfi(ifi)=1

        ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.1) THEN

          IF(pyr(0).GT.0.5d0) isfi(ifi)=1

        ELSEIF(kcfi(ifi).EQ.2.AND.nfis(ifi).EQ.2) THEN

          isfi(ifi)=1

          IF(pyr(0).GT.0.5d0) isfi(ifi)=2

        ENDIF

      ENDIF


C...Calculate Altarelli-Parisi weights.

      DO 170 kfl=-25,25

        wtapc(kfl)=0d0

        wtape(kfl)=0d0

        wtsf(kfl)=0d0

  170 CONTINUE

C...q -> q, g -> q.

      IF(iabs(kflb).LE.10) THEN

        wtapc(kflb)=(8d0/3d0)*log((1d0-xec-xb)*(xb+xec)/(xec*(1d0-xec)))

        wtapc(21)=0.5d0*(xb/(xb+xec)-xb/(1d0-xec))

C...f -> f, gamma -> f.

      ELSEIF(iabs(kflb).LE.20) THEN

        wtapf1=log((1d0-xee-xb)*(xb+xee)/(xee*(1d0-xee)))

        wtapf2=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))

        wtape(kflb)=2d0*(wtapf1+wtapf2)

        IF(mstp(12).GE.1) wtape(22)=xb/(xb+xee)-xb/(1d0-xee)

C...f -> g, g -> g.

      ELSEIF(kflb.EQ.21) THEN

        wtapq=(16d0/3d0)*(sqrt((1d0-xec)/xb)-sqrt((xb+xec)/xb))

        DO 180 kfl=1,mstp(58)

          wtapc(kfl)=wtapq

          wtapc(-kfl)=wtapq

  180   CONTINUE

        wtapc(21)=6d0*log((1d0-xec-xb)/xec)

C...f -> gamma, W+, W-.

      ELSEIF(kflb.EQ.22) THEN

        wtapf=log((1d0-xee-xb)*(1d0-xee)/(xee*(xb+xee)))/xb

        wtape(11)=wtapf

        wtape(-11)=wtapf

      ELSEIF(kflb.EQ.24) THEN

        wtape(-11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/

     &  (xee*(xb+xee)))/xb

      ELSEIF(kflb.EQ.-24) THEN

        wtape(11)=1d0/(4d0*paru(102))*log((1d0-xee-xb)*(1d0-xee)/

     &  (xee*(xb+xee)))/xb

      ENDIF


C...Calculate parton distribution weights and sum.

      ntry=0

  190 ntry=ntry+1

      IF(ntry.GT.500) THEN

        mint(51)=1

        RETURN

      ENDIF

      wtsumc=0d0

      wtsume=0d0

      xfbo=max(1d-10,xfb(kflb))

      DO 200 kfl=-25,25

        wtsf(kfl)=xfb(kfl)/xfbo

        wtsumc=wtsumc+wtapc(kfl)*wtsf(kfl)

        wtsume=wtsume+wtape(kfl)*wtsf(kfl)

  200 CONTINUE

      wtsumc=max(0.0001d0,wtsumc)

      wtsume=max(0.0001d0/fwte,wtsume)


C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).

      ntry2=0

  210 ntry2=ntry2+1

      IF(ntry2.GT.500) THEN

        mint(51)=1

        RETURN

      ENDIF

      IF(mcev.EQ.1) THEN

        IF(mstp(64).LE.0) THEN

          tevcb=tevcb+log(pyr(0))*paru(2)/(paru(111)*wtsumc)

        ELSEIF(mstp(64).EQ.1) THEN

          tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/wtsumc))

        ELSE

          tevcb=tevcb*exp(max(-50d0,log(pyr(0))*b0/(5d0*wtsumc)))

        ENDIF

      ENDIF

      IF(meev.EQ.1) THEN

        teveb=teveb*exp(max(-50d0,log(pyr(0))*paru(2)/

     &  (paru(101)*fwte*wtsume*temx)))

      ENDIF


C...Translate t into Q2 scale; choose between QCD and QED evolution.

  220 IF(mcev.EQ.1) q2cb=alam(jt)**2*exp(max(-50d0,tevcb))/fq2c

      IF(meev.EQ.1) q2eb=spme*exp(max(-50d0,teveb))

      mce=0

      IF(mcev.EQ.0.AND.meev.EQ.0) THEN

      ELSEIF(mcev.EQ.1.AND.meev.EQ.0) THEN

        IF(q2cb.GT.q2mncs(jt)) mce=1

      ELSEIF(mcev.EQ.0.AND.meev.EQ.1) THEN

        IF(q2eb.GT.q2mne) mce=2

      ELSEIF(q2mncs(jt).GT.q2mne) THEN

        mce=1

        IF(q2eb.GT.q2cb.OR.q2cb.LE.q2mncs(jt)) mce=2

        IF(mce.EQ.2.AND.q2eb.LE.q2mne) mce=0

      ELSE

        mce=2

        IF(q2cb.GT.q2eb.OR.q2eb.LE.q2mne) mce=1

        IF(mce.EQ.1.AND.q2cb.LE.q2mncs(jt)) mce=0

      ENDIF


C...Evolution possibly ended. Update t values.

      IF(mce.EQ.0) THEN

        q2b=0d0

        goto 250

      ELSEIF(mce.EQ.1) THEN

        q2b=q2cb

        q2ref=fq2c*q2b

        IF(meev.EQ.1) teveb=log(q2b/spme)

      ELSE

        q2b=q2eb

        q2ref=q2b

        IF(mcev.EQ.1) tevcb=log(fq2c*q2b/alam(jt)**2)

      ENDIF


C...Select flavour for branching parton.

      IF(mce.EQ.1) wtran=pyr(0)*wtsumc

      IF(mce.EQ.2) wtran=pyr(0)*wtsume

      kfla=-25

  230 kfla=kfla+1

      IF(mce.EQ.1) wtran=wtran-wtapc(kfla)*wtsf(kfla)

      IF(mce.EQ.2) wtran=wtran-wtape(kfla)*wtsf(kfla)

      IF(kfla.LE.24.AND.wtran.GT.0d0) goto 230

      IF(kfla.EQ.25) THEN

        q2b=0d0

        goto 250

      ENDIF


C...Choose z value and corrective weight.

      wtz=0d0

C...q -> q + g.

      IF(iabs(kfla).LE.10.AND.iabs(kflb).LE.10) THEN

        z=1d0-((1d0-xb-xec)/(1d0-xec))*

     &  (xec*(1d0-xec)/((xb+xec)*(1d0-xb-xec)))**pyr(0)

        wtz=0.5d0*(1d0+z**2)

C...q -> g + q.

      ELSEIF(iabs(kfla).LE.10.AND.kflb.EQ.21) THEN

        z=xb/(sqrt(xb+xec)+pyr(0)*(sqrt(1d0-xec)-sqrt(xb+xec)))**2

        wtz=0.5d0*(1d0+(1d0-z)**2)*sqrt(z)

C...f -> f + gamma.

      ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).LE.20) THEN

        IF(wtapf1.GT.pyr(0)*(wtapf1+wtapf2)) THEN

          z=1d0-((1d0-xb-xee)/(1d0-xee))*

     &    (xee*(1d0-xee)/((xb+xee)*(1d0-xb-xee)))**pyr(0)

        ELSE

          z=xb+xb*(xee/(1d0-xee))*

     &    ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)

        ENDIF

        wtz=0.5d0*(1d0+z**2)*(z-xb)/(1d0-xb)

C...f -> gamma + f.

      ELSEIF(iabs(kfla).LE.20.AND.kflb.EQ.22) THEN

        z=xb+xb*(xee/(1d0-xee))*

     &  ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)

        wtz=0.5d0*(1d0+(1d0-z)**2)*xb*(z-xb)/z

C...f -> W+- + f'.

      ELSEIF(iabs(kfla).LE.20.AND.iabs(kflb).EQ.24) THEN

        z=xb+xb*(xee/(1d0-xee))*

     &  ((1d0-xb-xee)*(1d0-xee)/(xee*(xb+xee)))**pyr(0)

        wtz=0.5d0*(1d0+(1d0-z)**2)*(xb*(z-xb)/z)*

     &  (q2b/(q2b+pmas(24,1)**2))

C...g -> q + qbar.

      ELSEIF(kfla.EQ.21.AND.iabs(kflb).LE.10) THEN

        z=xb/(1d0-xec)+pyr(0)*(xb/(xb+xec)-xb/(1d0-xec))

        wtz=1d0-2d0*z*(1d0-z)

C...g -> g + g.

      ELSEIF(kfla.EQ.21.AND.kflb.EQ.21) THEN

        z=1d0/(1d0+((1d0-xec-xb)/xb)*(xec/(1d0-xec-xb))**pyr(0))

        wtz=(1d0-z*(1d0-z))**2

C...gamma -> f + fbar.

      ELSEIF(kfla.EQ.22.AND.iabs(kflb).LE.20) THEN

        z=xb/(1d0-xee)+pyr(0)*(xb/(xb+xee)-xb/(1d0-xee))

        wtz=1d0-2d0*z*(1d0-z)

      ENDIF

      IF(mce.EQ.2) wtz=(wtz/fwte)*(teveb/temx)


C...Option with resummation of soft gluon emission as effective z shift.

      IF(mce.EQ.1) THEN

        IF(mstp(65).GE.1) THEN

          rsoft=6d0

          IF(kflb.NE.21) rsoft=8d0/3d0

          z=z*(tevcb/tevcsv(jt))**(rsoft*xec/((xb+xec)*b0))

          IF(z.LE.xb) goto 210

        ENDIF


C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.

        IF(mstp(64).GE.2) THEN

          IF((1d0-z)*q2b.LT.q2mncs(jt)) goto 210

          alprat=tevcb/(tevcb+log(1d0-z))

          IF(alprat.LT.5d0*pyr(0)) goto 210

          IF(alprat.GT.5d0) wtz=wtz*alprat/5d0

        ENDIF


C...Impose angular constraint in first branching from interference

C...with final state partons.

        IF(mfis.GE.1.AND.n.LE.ns+2.AND.ntry2.LT.200) THEN

          the2d=(4d0*q2b)/(dsh*(1d0-z))

          IF(n.EQ.ns+1.AND.isfi(1).GE.1) THEN

            IF(the2d.GT.thefis(1,isfi(1))**2) goto 210

          ELSEIF(n.EQ.ns+2.AND.isfi(2).GE.1) THEN

            IF(the2d.GT.thefis(2,isfi(2))**2) goto 210

          ENDIF

        ENDIF


C...Option with angular ordering requirement.

        IF(mstp(62).GE.3.AND.ntry2.LT.200) THEN

          the2t=(4d0*z**2*q2b)/(vint(2)*(1d0-z)*xb**2)

          IF(the2t.GT.the2(jt)) goto 210

        ENDIF

      ENDIF


C...Weighting with new parton distributions.

      mint(105)=mint(102+jt)

      mint(109)=mint(106+jt)

      IF(mstp(57).LE.1) THEN

        CALL pypdfu(kfbeam(jt),xb,q2ref,xfn)

      ELSE

        CALL pypdfl(kfbeam(jt),xb,q2ref,xfn)

      ENDIF

      xfbn=xfn(kflb)

      IF(xfbn.LT.1d-20) THEN

        IF(kfla.EQ.kflb) THEN

          tevcb=tevcbs

          teveb=tevebs

          wtapc(kflb)=0d0

          wtape(kflb)=0d0

          goto 190

        ELSEIF(mce.EQ.1.AND.tevcbs-tevcb.GT.0.2d0) THEN

          tevcb=0.5d0*(tevcbs+tevcb)

          goto 220

        ELSEIF(mce.EQ.2.AND.tevebs-teveb.GT.0.2d0) THEN

          teveb=0.5d0*(tevebs+teveb)

          goto 220

        ELSE

          xfbn=1d-10

          xfn(kflb)=xfbn

        ENDIF

      ENDIF

      DO 240 kfl=-25,25

        xfb(kfl)=xfn(kfl)

  240 CONTINUE

      xa=xb/z

      IF(mstp(57).LE.1) THEN

        CALL pypdfu(kfbeam(jt),xa,q2ref,xfa)

      ELSE

        CALL pypdfl(kfbeam(jt),xa,q2ref,xfa)

      ENDIF

      xfan=xfa(kfla)

      IF(xfan.LT.1d-20) goto 190

      wtsfa=wtsf(kfla)

      IF(wtz*xfan/xfbn.LT.pyr(0)*wtsfa) goto 190


C...Define two hard scatterers in their CM-frame.

  250 IF(n.EQ.ns+2) THEN

        dq2(jt)=q2b

        dplcm=sqrt((dsh+dq2(1)+dq2(2))**2-4d0*dq2(1)*dq2(2))/dshr

        DO 270 jr=1,2

          i=ns+jr

          IF(jr.EQ.1) ipo=ipus1

          IF(jr.EQ.2) ipo=ipus2

          DO 260 j=1,5

            k(i,j)=0

            p(i,j)=0d0

            v(i,j)=0d0

  260     CONTINUE

          k(i,1)=14

          k(i,2)=kfls(jr+2)

          k(i,4)=ipo

          k(i,5)=ipo

          p(i,3)=dplcm*(-1)**(jr+1)

          p(i,4)=(dsh+dq2(3-jr)-dq2(jr))/dshr

          p(i,5)=-sqrt(dq2(jr))

          k(ipo,1)=14

          k(ipo,3)=i

          k(ipo,4)=mod(k(ipo,4),mstu(5))+mstu(5)*i

          k(ipo,5)=mod(k(ipo,5),mstu(5))+mstu(5)*i

  270   CONTINUE


C...Find maximum allowed mass of timelike parton.

      ELSEIF(n.GT.ns+2) THEN

        jr=3-jt

        dq2(3)=q2b

        dpc(1)=p(is(1),4)

        dpc(2)=p(is(2),4)

        dpc(3)=0.5d0*(abs(p(is(1),3))+abs(p(is(2),3)))

        dpd(1)=dsh+dq2(jr)+dq2(jt)

        dpd(2)=dshz+dq2(jr)+dq2(3)

        dpd(3)=sqrt(dpd(1)**2-4d0*dq2(jr)*dq2(jt))

        dpd(4)=sqrt(dpd(2)**2-4d0*dq2(jr)*dq2(3))

        ikin=0

        IF(q2s(jr).GE.0.25d0*q2mnc.AND.dpd(1)-dpd(3).GE.

     &  1d-10*dpd(1)) ikin=1

        IF(ikin.EQ.0) dmsma=(dq2(jt)/zs(jt)-dq2(3))*

     &  (dsh/(dsh+dq2(jt))-dsh/(dshz+dq2(3)))

        IF(ikin.EQ.1) dmsma=(dpd(1)*dpd(2)-dpd(3)*dpd(4))/

     &  (2d0*dq2(jr))-dq2(jt)-dq2(3)


C...Generate timelike parton shower (if required).

        it=n

        DO 280 j=1,5

          k(it,j)=0

          p(it,j)=0d0

          v(it,j)=0d0

  280   CONTINUE

        k(it,1)=3

C...f -> f + g (gamma).

        IF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).LE.20) THEN

          k(it,2)=21

          IF(iabs(kflb).GE.11) k(it,2)=22

C...f -> g (gamma, W+-) + f.

        ELSEIF(iabs(kflb).LE.20.AND.iabs(kfls(jt+2)).GT.20) THEN

          k(it,2)=kflb

          IF(kfls(jt+2).EQ.24) THEN

            k(it,2)=-12

          ELSEIF(kfls(jt+2).EQ.-24) THEN

            k(it,2)=12

          ENDIF

C...g (gamma) -> f + fbar, g + g.

        ELSE

          k(it,2)=-kfls(jt+2)

          IF(kfls(jt+2).GT.20) k(it,2)=kfls(jt+2)

        ENDIF

        p(it,5)=pymass(k(it,2))

        IF(dmsma.LE.p(it,5)**2) goto 100

        IF(mstp(63).GE.1.AND.mce.EQ.1) THEN

          mstj48=mstj(48)

          parj85=parj(85)

          p(it,4)=(dshz-dsh-p(it,5)**2)/dshr

          p(it,3)=sqrt(p(it,4)**2-p(it,5)**2)

          IF(mstp(63).EQ.1) THEN

            q2tim=dmsma

          ELSEIF(mstp(63).EQ.2) THEN

            q2tim=min(dmsma,parp(71)*q2s(jt))

          ELSE

            q2tim=dmsma

            mstj(48)=1

            IF(ikin.EQ.0) dpt2=dmsma*(dshz+dq2(3))/(dsh+dq2(jt))

            IF(ikin.EQ.1) dpt2=dmsma*(0.5d0*dpd(1)*dpd(2)+0.5d0*dpd(3)*

     &      dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)))/(4d0*dsh*dpc(3)**2)

            parj(85)=sqrt(max(0d0,dpt2))*

     &      (1d0/p(it,4)+1d0/p(is(jt),4))

          ENDIF

          CALL pyshow(it,0,sqrt(q2tim))

          mstj(48)=mstj48

          parj(85)=parj85

          IF(n.GE.it+1) p(it,5)=p(it+1,5)

        ENDIF


C...Reconstruct kinematics of branching: timelike parton shower.

        dms=p(it,5)**2

        IF(ikin.EQ.0) dpt2=(dmsma-dms)*(dshz+dq2(3))/(dsh+dq2(jt))

        IF(ikin.EQ.1) dpt2=(dmsma-dms)*(0.5d0*dpd(1)*dpd(2)+

     &  0.5d0*dpd(3)*dpd(4)-dq2(jr)*(dq2(jt)+dq2(3)+dms))/

     &  (4d0*dsh*dpc(3)**2)

        IF(dpt2.LT.0d0) goto 100

        dpb(1)=(0.5d0*dpd(2)-dpc(jr)*(dshz+dq2(jr)-dq2(jt)-dms)/

     &  dshr)/dpc(3)-dpc(3)

        p(it,1)=sqrt(dpt2)

        p(it,3)=dpb(1)*(-1)**(jt+1)

        p(it,4)=sqrt(dpt2+dpb(1)**2+dms)

        IF(n.GE.it+1) THEN

          dpb(1)=sqrt(dpb(1)**2+dpt2)

          dpb(2)=sqrt(dpb(1)**2+dms)

          dpb(3)=p(it+1,3)

          dpb(4)=sqrt(dpb(3)**2+dms)

          dbez=(dpb(4)*dpb(1)-dpb(3)*dpb(2))/(dpb(4)*dpb(2)-dpb(3)*

     &    dpb(1))

          CALL pyrobo(it+1,n,0d0,0d0,0d0,0d0,dbez)

          the=pyangl(p(it,3),p(it,1))

          CALL pyrobo(it+1,n,the,0d0,0d0,0d0,0d0)

        ENDIF


C...Reconstruct kinematics of branching: spacelike parton.

        DO 290 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  290   CONTINUE

        k(n+1,1)=14

        k(n+1,2)=kflb

        p(n+1,1)=p(it,1)

        p(n+1,3)=p(it,3)+p(is(jt),3)

        p(n+1,4)=p(it,4)+p(is(jt),4)

        p(n+1,5)=-sqrt(dq2(3))


C...Define colour flow of branching.

        k(is(jt),3)=n+1

        k(it,3)=n+1

        im1=n+1

        im2=n+1

C...f -> f + gamma (Z, W).

        IF(iabs(k(it,2)).GE.22) THEN

          k(it,1)=1

          id1=is(jt)

          id2=is(jt)

C...f -> gamma (Z, W) + f.

        ELSEIF(iabs(k(is(jt),2)).GE.22) THEN

          id1=it

          id2=it

C...gamma -> q + qbar, g + g.

        ELSEIF(k(n+1,2).EQ.22) THEN

          id1=is(jt)

          id2=it

          im1=id2

          im2=id1

C...q -> q + g.

        ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21.AND.k(it,2).EQ.21) THEN

          id1=it

          id2=is(jt)

C...q -> g + q.

        ELSEIF(k(n+1,2).GT.0.AND.k(n+1,2).NE.21) THEN

          id1=is(jt)

          id2=it

C...qbar -> qbar + g.

        ELSEIF(k(n+1,2).LT.0.AND.k(it,2).EQ.21) THEN

          id1=is(jt)

          id2=it

C...qbar -> g + qbar.

        ELSEIF(k(n+1,2).LT.0) THEN

          id1=it

          id2=is(jt)

C...g -> g + g; g -> q + qbar.

        ELSEIF((k(it,2).EQ.21.AND.pyr(0).GT.0.5d0).OR.k(it,2).LT.0) THEN

          id1=is(jt)

          id2=it

        ELSE

          id1=it

          id2=is(jt)

        ENDIF

        IF(im1.EQ.n+1) k(im1,4)=k(im1,4)+id1

        IF(im2.EQ.n+1) k(im2,5)=k(im2,5)+id2

        k(id1,4)=k(id1,4)+mstu(5)*im1

        k(id2,5)=k(id2,5)+mstu(5)*im2

        IF(id1.NE.id2) THEN

          k(id1,5)=k(id1,5)+mstu(5)*id2

          k(id2,4)=k(id2,4)+mstu(5)*id1

        ENDIF

        n=n+1


C...Boost to new CM-frame.

        dbsvx=(p(n,1)+p(is(jr),1))/(p(n,4)+p(is(jr),4))

        dbsvz=(p(n,3)+p(is(jr),3))/(p(n,4)+p(is(jr),4))

        IF(dbsvx**2+dbsvz**2.GE.1d0) goto 100

        CALL pyrobo(ns+1,n,0d0,0d0,-dbsvx,0d0,-dbsvz)

        ir=n+(jt-1)*(is(1)-n)

        CALL pyrobo(ns+1,n,-pyangl(p(ir,3),p(ir,1)),paru(2)*pyr(0),

     &  0d0,0d0,0d0)

      ENDIF


C...Update kinematics variables.

      is(jt)=n

      dq2(jt)=q2b

      IF(mstp(62).GE.3) the2(jt)=the2t

      dsh=dshz


C...Save quantities; loop back.

      q2s(jt)=q2b

      IF((mcev.EQ.1.AND.q2b.GE.0.25d0*q2mnc).OR.

     &(meev.EQ.1.AND.q2b.GE.q2mne)) THEN

        kfls(jt+2)=kfls(jt)

        kfls(jt)=kfla

        xs(jt)=xa

        zs(jt)=z

        DO 300 kfl=-25,25

          xfs(jt,kfl)=xfa(kfl)

  300   CONTINUE

        tevcsv(jt)=tevcb

        tevesv(jt)=teveb

      ELSE

        more(jt)=0

        IF(jt.EQ.1) ipu1=n

        IF(jt.EQ.2) ipu2=n

      ENDIF

      IF(n.GT.mstu(4)-mstu(32)-10) THEN

        CALL pyerrm(11,'(PYSSPA:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) n=ns

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(more(1).EQ.1.OR.more(2).EQ.1) goto 150


C...Boost hard scattering partons to frame of shower initiators.

      DO 310 j=1,3

        robo(j+2)=(p(ns+1,j)+p(ns+2,j))/(p(ns+1,4)+p(ns+2,4))

  310 CONTINUE

      k(n+2,1)=1

      DO 320 j=1,5

        p(n+2,j)=p(ns+1,j)

  320 CONTINUE

      robot=robo(3)**2+robo(4)**2+robo(5)**2

      IF(robot.GE.0.999999d0) THEN

        robot=1.00001d0*sqrt(robot)

        robo(3)=robo(3)/robot

        robo(4)=robo(4)/robot

        robo(5)=robo(5)/robot

      ENDIF

      CALL pyrobo(n+2,n+2,0d0,0d0,-robo(3),-robo(4),-robo(5))

      robo(2)=pyangl(p(n+2,1),p(n+2,2))

      robo(1)=pyangl(p(n+2,3),sqrt(p(n+2,1)**2+p(n+2,2)**2))

      CALL pyrobo(mint(83)+5,ns,robo(1),robo(2),robo(3),robo(4),

     &robo(5))


C...Store user information. Reset Lambda value.

      k(ipu1,3)=mint(83)+3

      k(ipu2,3)=mint(83)+4

      DO 330 jt=1,2

        mint(12+jt)=kfls(jt)

        vint(140+jt)=xs(jt)

        IF(mint(18+jt).EQ.1) vint(140+jt)=vint(154+jt)*xs(jt)

  330 CONTINUE

      paru(112)=alams


      RETURN

      END


C*********************************************************************


C...PYRESD

C...Allows resonances to decay (including parton showers for hadronic

C...channels).


      SUBROUTINE pyresd(IRES)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint4/mwid(500),wids(500,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/,/pyint4/

C...Local arrays and complex and character variables.

      dimension iref(50,8),kdcy(3),kfl1(3),kfl2(3),kfl3(3),keql(3),

     &kcqm(3),kcq1(3),kcq2(3),kcq3(3),nsd(3),pmmn(3),ilin(6),

     &hgz(3,3),coup(6,4),corl(2,2,2),pk(6,4),pkk(6,6),cthe(3),

     &phi(3),wdtp(0:200),wdte(0:200,0:5),dbezqq(3),dpmo(5),xm(5)

      COMPLEX fgk,ha(6,6),hc(6,6)

      REAL tir,uir

      CHARACTER code*9,mass*9


C...The F, Xi and Xj functions of Gunion and Kunszt

C...(Phys. Rev. D33, 665, plus errata from the authors).

      fgk(i1,i2,i3,i4,i5,i6)=4.*ha(i1,i3)*hc(i2,i6)*(ha(i1,i5)*

     &hc(i1,i4)+ha(i3,i5)*hc(i3,i4))

      digk(dt,du)=-4d0*d34*d56+dt*(3d0*dt+4d0*du)+dt**2*(dt*du/

     &(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+2d0*(d34/d56+d56/d34))

      djgk(dt,du)=8d0*(d34+d56)**2-8d0*(d34+d56)*(dt+du)-6d0*dt*du-

     &2d0*dt*du*(dt*du/(d34*d56)-2d0*(1d0/d34+1d0/d56)*(dt+du)+

     &2d0*(d34/d56+d56/d34))


C...Some general constants.

      xw=paru(102)

      xwv=xw

      IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2

      xw1=1d0-xw

      sqmz=pmas(23,1)**2

      gmmz=pmas(23,1)*pmas(23,2)

      sqmw=pmas(24,1)**2

      gmmw=pmas(24,1)*pmas(24,2)

      sh=vint(44)


C...Reset original resonance configuration.

      DO 100 jt=1,8

        iref(1,jt)=0

  100 CONTINUE


C...Define initial one, two or three objects for subprocess.

      IF(ires.EQ.0) THEN

        isub=mint(1)

        IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN

          iref(1,1)=mint(84)+2+iset(isub)

          iref(1,4)=mint(83)+6+iset(isub)

        ELSEIF(iset(isub).EQ.2.OR.iset(isub).EQ.4) THEN

          iref(1,1)=mint(84)+1+iset(isub)

          iref(1,2)=mint(84)+2+iset(isub)

          iref(1,4)=mint(83)+5+iset(isub)

          iref(1,5)=mint(83)+6+iset(isub)

        ELSEIF(iset(isub).EQ.5) THEN

          iref(1,1)=mint(84)+3

          iref(1,2)=mint(84)+4

          iref(1,3)=mint(84)+5

          iref(1,4)=mint(83)+7

          iref(1,5)=mint(83)+8

          iref(1,6)=mint(83)+9

        ENDIF


C...Define original resonance for odd cases.

      ELSE

        isub=0

        iref(1,1)=ires

      ENDIF


C...Check if initial resonance has been moved (in resonance + jet).

      DO 120 jt=1,3

        IF(iref(1,jt).GT.0) THEN

          IF(k(iref(1,jt),1).GT.10) THEN

            kfa=iabs(k(iref(1,jt),2))

            IF(kfa.GE.6.AND.kchg(pycomp(kfa),2).NE.0) THEN

              DO 110 i=iref(1,jt)+1,n

                IF(k(i,1).LE.10.AND.k(i,2).EQ.k(iref(1,jt),2))

     &          iref(1,jt)=i

  110         CONTINUE

            ELSE

              kda=mod(k(iref(1,jt),4),mstu(4))

              IF(mwid(pycomp(kfa)).NE.0.AND.kda.GT.1) iref(1,jt)=kda

            ENDIF

          ENDIF

        ENDIF

  120 CONTINUE


C...Loop over decay history.

      np=1

      ip=0

  130 ip=ip+1

      ninh=0

      jtmax=2

      IF(iref(ip,2).EQ.0) jtmax=1

      IF(iref(ip,3).NE.0) jtmax=3

      it4=0

      nsav=n


C...Start treatment of one, two or three resonances in parallel.

  140 n=nsav

      DO 220 jt=1,jtmax

        id=iref(ip,jt)

        kdcy(jt)=0

        kfl1(jt)=0

        kfl2(jt)=0

        kfl3(jt)=0

        keql(jt)=0

        nsd(jt)=id


C...Check whether particle can/is allowed to decay.

        IF(id.EQ.0) goto 210

        kfa=iabs(k(id,2))

        kca=pycomp(kfa)

        IF(mwid(kca).EQ.0) goto 210

        IF(k(id,1).GT.10.OR.mdcy(kca,1).EQ.0) goto 210

        IF(kfa.EQ.6.OR.kfa.EQ.7.OR.kfa.EQ.8.OR.kfa.EQ.17.OR.

     &  kfa.EQ.18) it4=it4+1

        k(id,4)=mstu(5)*(k(id,4)/mstu(5))

        k(id,5)=mstu(5)*(k(id,5)/mstu(5))


C...Info for selection of decay channel: sign, pairings.

        IF(kchg(kca,3).EQ.0) THEN

          ipm=2

        ELSE

          ipm=(5-isign(1,k(id,2)))/2

        ENDIF

        kfb=0

        IF(jtmax.EQ.2) THEN

          kfb=iabs(k(iref(ip,3-jt),2))

        ELSEIF(jtmax.EQ.3) THEN

          jt2=jt+1-3*(jt/3)

          kfb=iabs(k(iref(ip,jt2),2))

          IF(kfb.NE.kfa) THEN

            jt2=jt+2-3*((jt+1)/3)

            kfb=iabs(k(iref(ip,jt2),2))

          ENDIF

        ENDIF


C...Select decay channel.

        IF(isub.EQ.1.OR.isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.

     &  isub.EQ.30.OR.isub.EQ.35.OR.isub.EQ.141) mint(61)=1

        CALL pywidt(kfa,p(id,5)**2,wdtp,wdte)

        wdte0s=wdte(0,1)+wdte(0,ipm)+wdte(0,4)

        IF(kfb.EQ.kfa) wdte0s=wdte0s+wdte(0,5)

        IF(wdte0s.LE.0d0) goto 210

        rkfl=wdte0s*pyr(0)

        idl=0

  150   idl=idl+1

        idc=idl+mdcy(kca,2)-1

        rkfl=rkfl-(wdte(idl,1)+wdte(idl,ipm)+wdte(idl,4))

        IF(kfb.EQ.kfa) rkfl=rkfl-wdte(idl,5)

        IF(idl.LT.mdcy(kca,3).AND.rkfl.GT.0d0) goto 150


C...Read out flavours and colour charges of decay channel chosen.

        kcqm(jt)=kchg(kca,2)*isign(1,k(id,2))

        IF(kcqm(jt).EQ.-2) kcqm(jt)=2

        kfl1(jt)=kfdp(idc,1)*isign(1,k(id,2))

        kfc1a=pycomp(iabs(kfl1(jt)))

        IF(kchg(kfc1a,3).EQ.0) kfl1(jt)=iabs(kfl1(jt))

        kcq1(jt)=kchg(kfc1a,2)*isign(1,kfl1(jt))

        IF(kcq1(jt).EQ.-2) kcq1(jt)=2

        kfl2(jt)=kfdp(idc,2)*isign(1,k(id,2))

        kfc2a=pycomp(iabs(kfl2(jt)))

        IF(kchg(kfc2a,3).EQ.0) kfl2(jt)=iabs(kfl2(jt))

        kcq2(jt)=kchg(kfc2a,2)*isign(1,kfl2(jt))

        IF(kcq2(jt).EQ.-2) kcq2(jt)=2

        kfl3(jt)=kfdp(idc,3)*isign(1,k(id,2))

        IF(kfl3(jt).NE.0) THEN

          kfc3a=pycomp(iabs(kfl3(jt)))

          IF(kchg(kfc3a,3).EQ.0) kfl3(jt)=iabs(kfl3(jt))

          kcq3(jt)=kchg(kfc3a,2)*isign(1,kfl3(jt))

          IF(kcq3(jt).EQ.-2) kcq3(jt)=2

        ENDIF


C...Set/save further info on channel.

        kdcy(jt)=1

        IF(kfb.EQ.kfa) keql(jt)=mdme(idc,1)

        nsd(jt)=n

        hgz(jt,1)=vint(111)

        hgz(jt,2)=vint(112)

        hgz(jt,3)=vint(114)


C...Select masses; to begin with assume resonances narrow.

        DO 170 i=1,3

          p(n+i,5)=0d0

          pmmn(i)=0d0

          IF(i.EQ.1) THEN

            kflw=iabs(kfl1(jt))

            kcw=kfc1a

          ELSEIF(i.EQ.2) THEN

            kflw=iabs(kfl2(jt))

            kcw=kfc2a

          ELSEIF(i.EQ.3) THEN

            IF(kfl3(jt).EQ.0) goto 170

            kflw=iabs(kfl3(jt))

            kcw=kfc3a

          ENDIF

          p(n+i,5)=pmas(kcw,1)

CMRENNA++

C...This prevents SUSY/t particles from becoming too light.

          IF(kflw/ksusy1.EQ.1.OR.kflw/ksusy1.EQ.2) THEN

            pmmn(i)=pmas(kcw,1)

            DO 160 idc=mdcy(kcw,2),mdcy(kcw,2)+mdcy(kcw,3)-1

              IF(mdme(idc,1).GT.0.AND.brat(idc).GT.1e-4) THEN

                pmsum=pmas(pycomp(kfdp(idc,1)),1)+

     &          pmas(pycomp(kfdp(idc,2)),1)

                IF(kfdp(idc,3).NE.0) pmsum=pmsum+

     &          pmas(pycomp(kfdp(idc,3)),1)

                pmmn(i)=min(pmmn(i),pmsum)

              ENDIF

  160       CONTINUE

CMRENNA--

          ELSEIF(kflw.EQ.6) THEN

            pmmn(i)=pmas(24,1)+pmas(5,1)

          ENDIF

  170   CONTINUE


C...Check which two out of three are widest.

        iwid1=1

        iwid2=2

        pwid1=pmas(kfc1a,2)

        pwid2=pmas(kfc2a,2)

        kflw1=iabs(kfl1(jt))

        kflw2=iabs(kfl2(jt))

        IF(kfl3(jt).NE.0) THEN

          pwid3=pmas(kfc3a,2)

          IF(pwid3.GT.pwid1.AND.pwid2.GE.pwid1) THEN

            iwid1=3

            pwid1=pwid3

            kflw1=iabs(kfl3(jt))

          ELSEIF(pwid3.GT.pwid2) THEN

            iwid2=3

            pwid2=pwid3

            kflw2=iabs(kfl3(jt))

          ENDIF

        ENDIF


C...If all narrow then only check that masses consistent.

        IF(mstp(42).LE.0.OR.(pwid1.LT.parp(41).AND.

     &  pwid2.LT.parp(41))) THEN

CMRENNA++

C....Handle near degeneracy cases.

          IF(kfa/ksusy1.EQ.1.OR.kfa/ksusy1.EQ.2) THEN

            IF(p(n+1,5)+p(n+2,5)+p(n+3,5).GT.p(id,5)) THEN

              p(n+1,5)=p(id,5)-p(n+2,5)-0.5d0

              IF(p(n+1,5).LT.0d0) p(n+1,5)=0d0

            ENDIF

          ENDIF

CMRENNA--

          IF(p(n+1,5)+p(n+2,5)+p(n+3,5)+parj(64).GT.p(id,5)) THEN

            CALL pyerrm(13,'(PYRESD:) daughter masses too large')

            mint(51)=1

            RETURN

          ENDIF


C...For three wide resonances select narrower of three

C...according to BW decoupled from rest.

        ELSE

          pmtot=p(id,5)

          IF(kfl3(jt).NE.0) THEN

            iwid3=6-iwid1-iwid2

            kflw3=iabs(kfl1(jt))+iabs(kfl2(jt))+iabs(kfl3(jt))-

     &      kflw1-kflw2

            loop=0

  180       loop=loop+1

            p(n+iwid3,5)=pymass(kflw3)

            IF(loop.LE.10.AND. p(n+iwid3,5).LE.pmmn(iwid3)) goto 180

            pmtot=pmtot-p(n+iwid3,5)

          ENDIF

C...Select other two correlated within remaining phase space.

          IF(ip.EQ.1) THEN

            ckin45=ckin(45)

            ckin47=ckin(47)

            ckin(45)=max(pmmn(iwid1),ckin(45))

            ckin(47)=max(pmmn(iwid2),ckin(47))

            CALL pyofsh(2,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),

     &      p(n+iwid2,5))

            ckin(45)=ckin45

            ckin(47)=ckin47

          ELSE

            ckin(49)=pmmn(iwid1)

            ckin(50)=pmmn(iwid2)

            CALL pyofsh(5,kfa,kflw1,kflw2,pmtot,p(n+iwid1,5),

     &      p(n+iwid2,5))

            ckin(49)=0d0

            ckin(50)=0d0

          ENDIF

          IF(mint(51).EQ.1) RETURN

        ENDIF


C...Begin fill decay products, with colour flow for coloured objects.

        mstu10=mstu(10)

        mstu(10)=1

        mstu(19)=1


CMRENNA++

C...1) Three-body decays of SUSY particles.

        IF(kfl3(jt).NE.0) THEN

          DO 200 i=n+1,n+3

            DO 190 j=1,5

              k(i,j)=0

              v(i,j)=0d0

  190       CONTINUE

  200     CONTINUE

          xm(1)=p(n+1,5)

          xm(2)=p(n+2,5)

          xm(3)=p(n+3,5)

          xm(5)=p(id,5)

          CALL pytbdy(xm)

          k(n+1,1)=1

          k(n+1,2)=kfl1(jt)

          k(n+2,1)=1

          k(n+2,2)=kfl2(jt)

          k(n+3,1)=1

          k(n+3,2)=kfl3(jt)

C...Set colour flow in three-body decays - programmed as special cases.

          IF(kfc2a.LE.6) THEN

            k(n+2,1)=3

            k(n+3,1)=3

            isid=4

            IF(kfl2(jt).LT.0) isid=5

            k(n+2,isid)=mstu(5)*(n+3)

            k(n+3,9-isid)=mstu(5)*(n+2)

          ENDIF

          IF(kfl1(jt).EQ.ksusy1+21) THEN

            k(n+1,1)=3

            k(n+2,1)=3

            k(n+3,1)=3

            isid=4

            IF(kfl2(jt).LT.0) isid=5

            k(n+1,isid)=mstu(5)*(n+2)

            k(n+1,9-isid)=mstu(5)*(n+3)

            k(n+2,isid)=mstu(5)*(n+1)

            k(n+3,9-isid)=mstu(5)*(n+1)

          ENDIF

          IF(kfa.EQ.ksusy1+21) THEN

            k(n+2,1)=3

            k(n+3,1)=3

            isid=4

            IF(kfl2(jt).LT.0) isid=5

            k(id,isid)=k(id,isid)+(n+2)

            k(id,9-isid)=k(id,9-isid)+(n+3)

            k(n+2,isid)=mstu(5)*id

            k(n+3,9-isid)=mstu(5)*id

          ENDIF

          n=n+3

CMRENNA--


C...2) Everything else two-body decay.

        ELSE

          CALL py2ent(n+1,kfl1(jt),kfl2(jt),p(id,5))

C...First set colour flow as if mother colour singlet.

          IF(kcq1(jt).NE.0) THEN

            k(n-1,1)=3

            IF(kcq1(jt).NE.-1) k(n-1,4)=mstu(5)*n

            IF(kcq1(jt).NE.1) k(n-1,5)=mstu(5)*n

          ENDIF

          IF(kcq2(jt).NE.0) THEN

            k(n,1)=3

            IF(kcq2(jt).NE.-1) k(n,4)=mstu(5)*(n-1)

            IF(kcq2(jt).NE.1) k(n,5)=mstu(5)*(n-1)

          ENDIF

C...Then redirect colour flow if mother (anti)triplet.

          IF(kcqm(jt).EQ.0) THEN

          ELSEIF(kcqm(jt).NE.2) THEN

            isid=4

            IF(kcqm(jt).EQ.-1) isid=5

            idau=n-1

            IF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.2) idau=n

            k(id,isid)=k(id,isid)+idau

            k(idau,isid)=mstu(5)*id

C...Then redirect colour flow if mother octet.

          ELSEIF(kcq1(jt).EQ.0.OR.kcq2(jt).EQ.0) THEN

            idau=n-1

            IF(kcq1(jt).EQ.0) idau=n

            k(id,4)=k(id,4)+idau

            k(id,5)=k(id,5)+idau

            k(idau,4)=mstu(5)*id

            k(idau,5)=mstu(5)*id

          ELSE

            isid=4

            IF(kcq1(jt).EQ.-1) isid=5

            IF(kcq1(jt).EQ.2) isid=int(4.5d0+pyr(0))

            k(id,isid)=k(id,isid)+(n-1)

            k(id,9-isid)=k(id,9-isid)+n

            k(n-1,isid)=mstu(5)*id

            k(n,9-isid)=mstu(5)*id

          ENDIF

        ENDIF


C...End loop over resonances for daughter flavour and mass selection.

        mstu(10)=mstu10

  210   IF(mwid(kca).NE.0.AND.(kfl1(jt).EQ.0.OR.kfl3(jt).NE.0))

     &  ninh=ninh+1

        IF(ires.GT.0.AND.mwid(kca).NE.0.AND.kfl1(jt).EQ.0) THEN

          WRITE(code,'(I9)') k(id,2)

          WRITE(mass,'(F9.3)') p(id,5)

          CALL pyerrm(3,'(PYRESD:) Failed to decay particle'//

     &    code//' with mass'//mass)

          mint(51)=1

          RETURN

        ENDIF

  220 CONTINUE


C...Check for allowed combinations. Skip if no decays.

      IF(jtmax.EQ.1) THEN

        IF(kdcy(1).EQ.0) goto 560

      ELSEIF(jtmax.EQ.2) THEN

        IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0) goto 560

        IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 140

        IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 140

      ELSEIF(jtmax.EQ.3) THEN

        IF(kdcy(1).EQ.0.AND.kdcy(2).EQ.0.AND.kdcy(3).EQ.0) goto 560

        IF(keql(1).EQ.4.AND.keql(2).EQ.4) goto 140

        IF(keql(1).EQ.4.AND.keql(3).EQ.4) goto 140

        IF(keql(2).EQ.4.AND.keql(3).EQ.4) goto 140

        IF(keql(1).EQ.5.AND.keql(2).EQ.5) goto 140

        IF(keql(1).EQ.5.AND.keql(3).EQ.5) goto 140

        IF(keql(2).EQ.5.AND.keql(3).EQ.5) goto 140

      ENDIF


C...Special case: matrix element option for Z0 decay to quarks.

      IF(mstp(48).EQ.1.AND.isub.EQ.1.AND.jtmax.EQ.1.AND.

     &iabs(mint(11)).EQ.11.AND.iabs(kfl1(1)).LE.5) THEN


C...Check consistency of MSTJ options set.

        IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN

          CALL pyerrm(6,

     &    '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')

          mstj(110)=1

        ENDIF

        IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN

          CALL pyerrm(6,

     &    '(PYRESD) MSTJ(109) value requires MSTJ(111) = 0')

          mstj(111)=0

        ENDIF


C...Select alpha_strong behaviour.

        mst111=mstu(111)

        par112=paru(112)

        mstu(111)=mstj(108)

        IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))

     &  mstu(111)=1

        paru(112)=parj(121)

        IF(mstu(111).EQ.2) paru(112)=parj(122)


C...Find axial fraction in total cross section for scalar gluon model.

        parj(171)=0d0

        IF((iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.1).OR.

     &  (mstj(101).EQ.5.AND.mstj(49).EQ.1)) THEN

          poll=1d0-parj(131)*parj(132)

          sff=1d0/(16d0*xw*xw1)

          sfw=p(id,5)**4/((p(id,5)**2-parj(123)**2)**2+

     &    (parj(123)*parj(124))**2)

          sfi=sfw*(1d0-(parj(123)/p(id,5))**2)

          ve=4d0*xw-1d0

          hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))

          hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*

     &    (parj(132)-parj(131)))

          kflc=iabs(kfl1(1))

          pmq=pymass(kflc)

          qf=kchg(kflc,1)/3d0

          vq=1d0

          IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,

     &    1d0-(2d0*pmq/p(id,5))**2))

          vf=sign(1d0,qf)-4d0*qf*xw

          rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+

     &    vf**2*hf1w)+vq**3*hf1w

          IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)

        ENDIF


C...Choice of jet configuration.

        CALL pyxjet(p(id,5),njet,cut)

        kflc=iabs(kfl1(1))

        kfln=21

        IF(njet.EQ.4) THEN

          CALL pyx4jt(njet,cut,kflc,p(id,5),kfln,x1,x2,x4,x12,x14)

        ELSEIF(njet.EQ.3) THEN

          CALL pyx3jt(njet,cut,kflc,p(id,5),x1,x3)

        ELSE

          mstj(120)=1

        ENDIF


C...Fill jet configuration; return if incorrect kinematics.

        nc=n-2

        IF(njet.EQ.2.AND.mstj(101).NE.5) THEN

          CALL py2ent(nc+1,kflc,-kflc,p(id,5))

        ELSEIF(njet.EQ.2) THEN

          CALL py2ent(-(nc+1),kflc,-kflc,p(id,5))

        ELSEIF(njet.EQ.3) THEN

          CALL py3ent(nc+1,kflc,21,-kflc,p(id,5),x1,x3)

        ELSEIF(kfln.EQ.21) THEN

          CALL py4ent(nc+1,kflc,kfln,kfln,-kflc,p(id,5),x1,x2,x4,

     &    x12,x14)

        ELSE

          CALL py4ent(nc+1,kflc,-kfln,kfln,-kflc,p(id,5),x1,x2,x4,

     &    x12,x14)

        ENDIF

        IF(mstu(24).NE.0) THEN

          mint(51)=1

          mstu(111)=mst111

          paru(112)=par112

          RETURN

        ENDIF


C...Angular orientation according to matrix element.

        IF(mstj(106).EQ.1) THEN

          CALL pyxdif(nc,njet,kflc,p(id,5),chi,the,phi)

          IF(mint(11).LT.0) the=paru(1)-the

          cthe(1)=cos(the)

          CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)

          CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)

        ENDIF


C...Boost partons to Z0 rest frame.

        CALL pyrobo(nc+1,n,0d0,0d0,p(id,1)/p(id,4),

     &  p(id,2)/p(id,4),p(id,3)/p(id,4))


C...Mark decayed resonance and add documentation lines,

        k(id,1)=k(id,1)+10

        idoc=mint(83)+mint(4)

        DO 240 i=nc+1,n

          i1=mint(83)+mint(4)+1

          k(i,3)=i1

          IF(mstp(128).GE.1) k(i,3)=id

          IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN

            mint(4)=mint(4)+1

            k(i1,1)=21

            k(i1,2)=k(i,2)

            k(i1,3)=iref(ip,4)

            DO 230 j=1,5

              p(i1,j)=p(i,j)

  230       CONTINUE

          ENDIF

  240   CONTINUE


C...Generate parton shower.

        IF(mstj(101).EQ.5) CALL pyshow(n-1,n,p(id,5))


C... End special case for Z0: skip ahead.

        mstu(111)=mst111

        paru(112)=par112

        goto 550

      ENDIF


C...Order incoming partons and outgoing resonances.

      IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN

        ilin(1)=mint(84)+1

        IF(k(mint(84)+1,2).GT.0) ilin(1)=mint(84)+2

        IF(k(ilin(1),2).EQ.21) ilin(1)=2*mint(84)+3-ilin(1)

        ilin(2)=2*mint(84)+3-ilin(1)

        imin=1

        IF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.iref(ip,7)

     &  .EQ.36) imin=3

        imax=2

        iord=1

        IF(k(iref(ip,1),2).EQ.23) iord=2

        IF(k(iref(ip,1),2).EQ.24.AND.k(iref(ip,2),2).EQ.-24) iord=2

        iakipd=iabs(k(iref(ip,iord),2))

        IF(iakipd.EQ.25.OR.iakipd.EQ.35.OR.iakipd.EQ.36) iord=3-iord

        IF(kdcy(iord).EQ.0) iord=3-iord


C...Order decay products of resonances.

        DO 250 jt=iord,3-iord,3-2*iord

          IF(kdcy(jt).EQ.0) THEN

            ilin(imax+1)=nsd(jt)

            imax=imax+1

          ELSEIF(k(nsd(jt)+1,2).GT.0) THEN

            ilin(imax+1)=n+2*jt-1

            ilin(imax+2)=n+2*jt

            imax=imax+2

            k(n+2*jt-1,2)=k(nsd(jt)+1,2)

            k(n+2*jt,2)=k(nsd(jt)+2,2)

          ELSE

            ilin(imax+1)=n+2*jt

            ilin(imax+2)=n+2*jt-1

            imax=imax+2

            k(n+2*jt-1,2)=k(nsd(jt)+1,2)

            k(n+2*jt,2)=k(nsd(jt)+2,2)

          ENDIF

  250   CONTINUE


C...Find charge, isospin, left- and righthanded couplings.

        DO 270 i=imin,imax

          DO 260 j=1,4

            coup(i,j)=0d0

  260     CONTINUE

          kfa=iabs(k(ilin(i),2))

          IF(kfa.EQ.0.OR.kfa.GT.20) goto 270

          coup(i,1)=kchg(kfa,1)/3d0

          coup(i,2)=(-1)**mod(kfa,2)

          coup(i,4)=-2d0*coup(i,1)*xwv

          coup(i,3)=coup(i,2)+coup(i,4)

  270   CONTINUE


C...Full propagator dependence and flavour correlations for 2 gamma*/Z.

        IF(isub.EQ.22) THEN

          DO 300 i=3,5,2

            i1=iord

            IF(i.EQ.5) i1=3-iord

            DO 290 j1=1,2

              DO 280 j2=1,2

                corl(i/2,j1,j2)=coup(1,1)**2*hgz(i1,1)*coup(i,1)**2/

     &          16d0+coup(1,1)*coup(1,j1+2)*hgz(i1,2)*coup(i,1)*

     &          coup(i,j2+2)/4d0+coup(1,j1+2)**2*hgz(i1,3)*

     &          coup(i,j2+2)**2

  280         CONTINUE

  290       CONTINUE

  300     CONTINUE

          cowt12=(corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+

     &    (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2))

          comx12=(corl(1,1,1)+corl(1,1,2)+corl(1,2,1)+corl(1,2,2))*

     &    (corl(2,1,1)+corl(2,1,2)+corl(2,2,1)+corl(2,2,2))

          IF(cowt12.LT.pyr(0)*comx12) goto 140

        ENDIF

      ENDIF


C...Select angular orientation type - Z'/W' only.

      mzpwp=0

      IF(isub.EQ.141) THEN

        IF(pyr(0).LT.paru(130)) mzpwp=1

        IF(ip.EQ.2) THEN

          IF(iabs(k(iref(2,1),2)).EQ.37) mzpwp=2

          iakir=iabs(k(iref(2,2),2))

          IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2

        ENDIF

        IF(ip.GE.3) mzpwp=2

      ELSEIF(isub.EQ.142) THEN

        IF(pyr(0).LT.paru(136)) mzpwp=1

        IF(ip.EQ.2) THEN

          iakir=iabs(k(iref(2,2),2))

          IF(iakir.EQ.25.OR.iakir.EQ.35.OR.iakir.EQ.36) mzpwp=2

        ENDIF

        IF(ip.GE.3) mzpwp=2

      ENDIF


C...Select random angles (begin of weighting procedure).

  310 DO 320 jt=1,jtmax

        IF(kdcy(jt).EQ.0) goto 320

        IF(jtmax.EQ.1) THEN

          cthe(jt)=vint(13)+(vint(33)-vint(13)+vint(34)-vint(14))*pyr(0)

          IF(cthe(jt).GT.vint(33)) cthe(jt)=cthe(jt)+vint(14)-vint(33)

          phi(jt)=vint(24)

        ELSE

          cthe(jt)=2d0*pyr(0)-1d0

          phi(jt)=paru(2)*pyr(0)

        ENDIF

  320 CONTINUE


      IF(jtmax.EQ.2.AND.mstp(47).GE.1.AND.ninh.EQ.0) THEN

C...Construct massless four-vectors.

        DO 340 i=n+1,n+4

          k(i,1)=1

          DO 330 j=1,5

            p(i,j)=0d0

            v(i,j)=0d0

  330     CONTINUE

  340   CONTINUE

        DO 350 jt=1,jtmax

          IF(kdcy(jt).EQ.0) goto 350

          id=iref(ip,jt)

          p(n+2*jt-1,3)=0.5d0*p(id,5)

          p(n+2*jt-1,4)=0.5d0*p(id,5)

          p(n+2*jt,3)=-0.5d0*p(id,5)

          p(n+2*jt,4)=0.5d0*p(id,5)

          CALL pyrobo(n+2*jt-1,n+2*jt,acos(cthe(jt)),phi(jt),

     &    p(id,1)/p(id,4),p(id,2)/p(id,4),p(id,3)/p(id,4))

  350   CONTINUE


C...Store incoming and outgoing momenta, with random rotation to

C...avoid accidental zeroes in HA expressions.

        DO 370 i=1,imax

          k(n+4+i,1)=1

          p(n+4+i,4)=sqrt(p(ilin(i),1)**2+p(ilin(i),2)**2+

     &    p(ilin(i),3)**2+p(ilin(i),5)**2)

          p(n+4+i,5)=p(ilin(i),5)

          DO 360 j=1,3

            p(n+4+i,j)=p(ilin(i),j)

  360     CONTINUE

  370   CONTINUE

  380   therr=acos(2d0*pyr(0)-1d0)

        phirr=paru(2)*pyr(0)

        CALL pyrobo(n+5,n+4+imax,therr,phirr,0d0,0d0,0d0)

        DO 400 i=1,imax

          IF(p(n+4+i,1)**2+p(n+4+i,2)**2.LT.1d-4*p(n+4+i,4)**2) goto 380

          DO 390 j=1,4

            pk(i,j)=p(n+4+i,j)

  390     CONTINUE

  400   CONTINUE


C...Calculate internal products.

        IF(isub.EQ.22.OR.isub.EQ.23.OR.isub.EQ.25.OR.isub.EQ.141.OR.

     &  isub.EQ.142) THEN

          DO 420 i1=imin,imax-1

            DO 410 i2=i1+1,imax

              ha(i1,i2)=sngl(sqrt((pk(i1,4)-pk(i1,3))*(pk(i2,4)+

     &        pk(i2,3))/(1d-20+pk(i1,1)**2+pk(i1,2)**2)))*

     &        cmplx(sngl(pk(i1,1)),sngl(pk(i1,2)))-

     &        sngl(sqrt((pk(i1,4)+pk(i1,3))*(pk(i2,4)-pk(i2,3))/

     &        (1d-20+pk(i2,1)**2+pk(i2,2)**2)))*

     &        cmplx(sngl(pk(i2,1)),sngl(pk(i2,2)))

              hc(i1,i2)=conjg(ha(i1,i2))

              IF(i1.LE.2) ha(i1,i2)=cmplx(0.,1.)*ha(i1,i2)

              IF(i1.LE.2) hc(i1,i2)=cmplx(0.,1.)*hc(i1,i2)

              ha(i2,i1)=-ha(i1,i2)

              hc(i2,i1)=-hc(i1,i2)

  410       CONTINUE

  420     CONTINUE

        ENDIF

        DO 440 i=1,2

          DO 430 j=1,4

            pk(i,j)=-pk(i,j)

  430     CONTINUE

  440   CONTINUE

        DO 460 i1=imin,imax-1

          DO 450 i2=i1+1,imax

            pkk(i1,i2)=2d0*(pk(i1,4)*pk(i2,4)-pk(i1,1)*pk(i2,1)-

     &      pk(i1,2)*pk(i2,2)-pk(i1,3)*pk(i2,3))

            pkk(i2,i1)=pkk(i1,i2)

  450     CONTINUE

  460   CONTINUE

      ENDIF


      kfagm=iabs(iref(ip,7))

      IF(mstp(47).LE.0.OR.ninh.NE.0) THEN

C...Isotropic decay selected by user.

        wt=1d0

        wtmax=1d0


      ELSEIF(it4.GE.1) THEN

C... Isotropic decay t -> b + W etc for 4th generation q and l.

        wt=1d0

        wtmax=1d0


      ELSEIF(iref(ip,7).EQ.25.OR.iref(ip,7).EQ.35.OR.

     &  iref(ip,7).EQ.36) THEN

C...Angular weight for h0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.

        IF(ip.EQ.1) wtmax=sh**2

        IF(ip.GE.2) wtmax=p(iref(ip,8),5)**4

        kfa=iabs(k(iref(ip,1),2))

        IF(kfa.EQ.23) THEN

          kflf1a=iabs(kfl1(1))

          ef1=kchg(kflf1a,1)/3d0

          af1=sign(1d0,ef1+0.1d0)

          vf1=af1-4d0*ef1*xwv

          kflf2a=iabs(kfl1(2))

          ef2=kchg(kflf2a,1)/3d0

          af2=sign(1d0,ef2+0.1d0)

          vf2=af2-4d0*ef2*xwv

          va12as=4d0*vf1*af1*vf2*af2/((vf1**2+af1**2)*(vf2**2+af2**2))

          wt=8d0*(1d0+va12as)*pkk(3,5)*pkk(4,6)+

     &    8d0*(1d0-va12as)*pkk(3,6)*pkk(4,5)

        ELSEIF(kfa.EQ.24) THEN

          wt=16d0*pkk(3,5)*pkk(4,6)

        ELSE

          wt=wtmax

        ENDIF


      ELSEIF((kfagm.EQ.6.OR.kfagm.EQ.7.OR.kfagm.EQ.8.OR.

     &  kfagm.EQ.17.OR.kfagm.EQ.18).AND.iabs(k(iref(ip,1),2)).EQ.24)

     &  THEN

C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.

        i1=iref(ip,8)

        IF(mod(kfagm,2).EQ.0) THEN

          i2=n+1

          i3=n+2

        ELSE

          i2=n+2

          i3=n+1

        ENDIF

        i4=iref(ip,2)

        wt=(p(i1,4)*p(i2,4)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-

     &  p(i1,3)*p(i2,3))*(p(i3,4)*p(i4,4)-p(i3,1)*p(i4,1)-

     &  p(i3,2)*p(i4,2)-p(i3,3)*p(i4,3))

        wtmax=(p(i1,5)**4-p(iref(ip,1),5)**4)/8d0


      ELSEIF(isub.EQ.1) THEN

C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.

        ei=kchg(iabs(mint(15)),1)/3d0

        ai=sign(1d0,ei+0.1d0)

        vi=ai-4d0*ei*xwv

        ef=kchg(iabs(kfl1(1)),1)/3d0

        af=sign(1d0,ef+0.1d0)

        vf=af-4d0*ef*xwv

        rmf=min(1d0,4d0*pmas(iabs(kfl1(1)),1)**2/sh)

        wt1=ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+

     &  (vi**2+ai**2)*vint(114)*(vf**2+(1d0-rmf)*af**2)

        wt2=rmf*(ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+

     &  (vi**2+ai**2)*vint(114)*vf**2)

        wt3=sqrt(1d0-rmf)*(ei*ai*vint(112)*ef*af+

     &  4d0*vi*ai*vint(114)*vf*af)

        wt=wt1*(1d0+cthe(1)**2)+wt2*(1d0-cthe(1)**2)+

     &  2d0*wt3*cthe(1)*isign(1,mint(15)*kfl1(1))

        wtmax=wt1+abs(wt3)


      ELSEIF(isub.EQ.2) THEN

C...Angular weight for W+/- -> 2 quarks/leptons.

        wt=(1d0+cthe(1)*isign(1,mint(15)*kfl1(1)))**2

        wtmax=4d0


      ELSEIF(isub.EQ.15.OR.isub.EQ.19) THEN

C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->

C...-> gluon/gamma + 2 quarks/leptons.

        clilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+

     &  coup(1,3)**2*hgz(2,3)*coup(3,3)**2

        clirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+

     &  coup(1,3)**2*hgz(2,3)*coup(3,4)**2

        crilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+

     &  coup(1,4)**2*hgz(2,3)*coup(3,3)**2

        crirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+

     &  coup(1,4)**2*hgz(2,3)*coup(3,4)**2

        wt=(clilf+crirf)*(pkk(1,3)**2+pkk(2,4)**2)+

     &  (clirf+crilf)*(pkk(1,4)**2+pkk(2,3)**2)

        wtmax=(clilf+clirf+crilf+crirf)*

     &  ((pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2)


      ELSEIF(isub.EQ.16.OR.isub.EQ.20) THEN

C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->

C...-> gluon/gamma + 2 quarks/leptons.

        wt=pkk(1,3)**2+pkk(2,4)**2

        wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(2,3)+pkk(2,4))**2


      ELSEIF(isub.EQ.22) THEN

C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.

        s34=p(iref(ip,iord),5)**2

        s56=p(iref(ip,3-iord),5)**2

        ti=pkk(1,3)+pkk(1,4)+s34

        ui=pkk(1,5)+pkk(1,6)+s56

        tir=REAL(ti)

        uir=REAL(ui)

        fgk135=abs(fgk(1,2,3,4,5,6)/tir+fgk(1,2,5,6,3,4)/uir)**2

        fgk145=abs(fgk(1,2,4,3,5,6)/tir+fgk(1,2,5,6,4,3)/uir)**2

        fgk136=abs(fgk(1,2,3,4,6,5)/tir+fgk(1,2,6,5,3,4)/uir)**2

        fgk146=abs(fgk(1,2,4,3,6,5)/tir+fgk(1,2,6,5,4,3)/uir)**2

        fgk253=abs(fgk(2,1,5,6,3,4)/tir+fgk(2,1,3,4,5,6)/uir)**2

        fgk263=abs(fgk(2,1,6,5,3,4)/tir+fgk(2,1,3,4,6,5)/uir)**2

        fgk254=abs(fgk(2,1,5,6,4,3)/tir+fgk(2,1,4,3,5,6)/uir)**2

        fgk264=abs(fgk(2,1,6,5,4,3)/tir+fgk(2,1,4,3,6,5)/uir)**2

        wt=

     &  corl(1,1,1)*corl(2,1,1)*fgk135+corl(1,1,2)*corl(2,1,1)*fgk145+

     &  corl(1,1,1)*corl(2,1,2)*fgk136+corl(1,1,2)*corl(2,1,2)*fgk146+

     &  corl(1,2,1)*corl(2,2,1)*fgk253+corl(1,2,2)*corl(2,2,1)*fgk263+

     &  corl(1,2,1)*corl(2,2,2)*fgk254+corl(1,2,2)*corl(2,2,2)*fgk264

        wtmax=16d0*((corl(1,1,1)+corl(1,1,2))*(corl(2,1,1)+corl(2,1,2))+

     &  (corl(1,2,1)+corl(1,2,2))*(corl(2,2,1)+corl(2,2,2)))*s34*s56*

     &  ((ti**2+ui**2+2d0*sh*(s34+s56))/(ti*ui)-s34*s56*(1d0/ti**2+

     &  1d0/ui**2))


      ELSEIF(isub.EQ.23) THEN

C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.

        d34=p(iref(ip,iord),5)**2

        d56=p(iref(ip,3-iord),5)**2

        dt=pkk(1,3)+pkk(1,4)+d34

        du=pkk(1,5)+pkk(1,6)+d56

        facbw=1d0/((sh-sqmw)**2+sqmw*pmas(24,2)**2)

        cawz=coup(2,3)/dt-2d0*xw1*coup(1,2)*(sh-sqmw)*facbw

        cbwz=coup(1,3)/du+2d0*xw1*coup(1,2)*(sh-sqmw)*facbw

        fgk135=abs(REAL(cawz)*fgk(1,2,3,4,5,6)+

     &  REAL(cbwz)*fgk(1,2,5,6,3,4))

        fgk136=abs(REAL(cawz)*fgk(1,2,3,4,6,5)+

     &  REAL(cbwz)*fgk(1,2,6,5,3,4))

        wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2

        wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*(cawz**2*

     &  digk(dt,du)+cbwz**2*digk(du,dt)+cawz*cbwz*djgk(dt,du))


      ELSEIF(isub.EQ.24.OR.isub.EQ.171.OR.isub.EQ.176) THEN

C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0

C...(or H0, or A0).

        wt=((coup(1,3)*coup(3,3))**2+(coup(1,4)*coup(3,4))**2)*

     &  pkk(1,3)*pkk(2,4)+((coup(1,3)*coup(3,4))**2+(coup(1,4)*

     &  coup(3,3))**2)*pkk(1,4)*pkk(2,3)

        wtmax=(coup(1,3)**2+coup(1,4)**2)*(coup(3,3)**2+coup(3,4)**2)*

     &  (pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))


      ELSEIF(isub.EQ.25) THEN

C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.

        d34=p(iref(ip,iord),5)**2

        d56=p(iref(ip,3-iord),5)**2

        dt=pkk(1,3)+pkk(1,4)+d34

        du=pkk(1,5)+pkk(1,6)+d56

        facbw=1d0/((sh-sqmz)**2+sqmz*pmas(23,2)**2)

        cdww=(coup(1,3)*sqmz*(sh-sqmz)*facbw+coup(1,2))/sh

        caww=cdww+0.5d0*(coup(1,2)+1d0)/dt

        cbww=cdww+0.5d0*(coup(1,2)-1d0)/du

        ccww=coup(1,4)*sqmz*(sh-sqmz)*facbw/sh

        fgk135=abs(REAL(caww)*fgk(1,2,3,4,5,6)-

     &  REAL(cbww)*fgk(1,2,5,6,3,4))

        fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))

        wt=fgk135**2+(ccww*fgk253)**2

        wtmax=4d0*d34*d56*(caww**2*digk(dt,du)+cbww**2*digk(du,dt)-caww*

     &  cbww*djgk(dt,du)+ccww**2*(digk(dt,du)+digk(du,dt)-djgk(dt,du)))


      ELSEIF(isub.EQ.26.OR.isub.EQ.172.OR.isub.EQ.177) THEN

C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0

C...(or H0, or A0).

        wt=pkk(1,3)*pkk(2,4)

        wtmax=(pkk(1,3)+pkk(1,4))*(pkk(2,3)+pkk(2,4))


      ELSEIF(isub.EQ.30.OR.isub.EQ.35) THEN

C...Angular weight for f + g/gamma -> f + (gamma*/Z0)

C...-> f + 2 quarks/leptons.

        clilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+

     &  coup(1,3)**2*hgz(2,3)*coup(3,3)**2

        clirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,3)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+

     &  coup(1,3)**2*hgz(2,3)*coup(3,4)**2

        crilf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,3)/4d0+

     &  coup(1,4)**2*hgz(2,3)*coup(3,3)**2

        crirf=coup(1,1)**2*hgz(2,1)*coup(3,1)**2/16d0+

     &  coup(1,1)*coup(1,4)*hgz(2,2)*coup(3,1)*coup(3,4)/4d0+

     &  coup(1,4)**2*hgz(2,3)*coup(3,4)**2

        IF(k(ilin(1),2).GT.0) wt=(clilf+crirf)*(pkk(1,4)**2+

     &  pkk(3,5)**2)+(clirf+crilf)*(pkk(1,3)**2+pkk(4,5)**2)

        IF(k(ilin(1),2).LT.0) wt=(clilf+crirf)*(pkk(1,3)**2+

     &  pkk(4,5)**2)+(clirf+crilf)*(pkk(1,4)**2+pkk(3,5)**2)

        wtmax=(clilf+clirf+crilf+crirf)*

     &  ((pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2)


      ELSEIF(isub.EQ.31) THEN

C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons.

        IF(k(ilin(1),2).GT.0) wt=pkk(1,4)**2+pkk(3,5)**2

        IF(k(ilin(1),2).LT.0) wt=pkk(1,3)**2+pkk(4,5)**2

        wtmax=(pkk(1,3)+pkk(1,4))**2+(pkk(3,5)+pkk(4,5))**2


      ELSEIF(isub.EQ.71.OR.isub.EQ.72.OR.isub.EQ.73.OR.isub.EQ.76.OR.

     &  isub.EQ.77) THEN

C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).

        wt=16d0*pkk(3,5)*pkk(4,6)

        wtmax=sh**2


      ELSEIF(isub.EQ.110) THEN

C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.

        wt=1d0

        wtmax=1d0


      ELSEIF(isub.EQ.141) THEN

        IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN

C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.

C...Couplings of incoming flavour.

          kfai=iabs(mint(15))

          ei=kchg(kfai,1)/3d0

          ai=sign(1d0,ei+0.1d0)

          vi=ai-4d0*ei*xwv

          kfaic=1

          IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2

          IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3

          IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4

          vpi=paru(119+2*kfaic)

          api=paru(120+2*kfaic)

C...Couplings of final flavour.

          kfaf=iabs(kfl1(1))

          ef=kchg(kfaf,1)/3d0

          af=sign(1d0,ef+0.1d0)

          vf=af-4d0*ef*xwv

          kfafc=1

          IF(kfaf.LE.10.AND.mod(kfaf,2).EQ.0) kfafc=2

          IF(kfaf.GT.10.AND.mod(kfaf,2).NE.0) kfafc=3

          IF(kfaf.GT.10.AND.mod(kfaf,2).EQ.0) kfafc=4

          vpf=paru(119+2*kfafc)

          apf=paru(120+2*kfafc)

C...Asymmetry and weight.

          asym=2d0*(ei*ai*vint(112)*ef*af+ei*api*vint(113)*ef*apf+

     &    4d0*vi*ai*vint(114)*vf*af+(vi*api+vpi*ai)*vint(115)*

     &    (vf*apf+vpf*af)+4d0*vpi*api*vint(116)*vpf*apf)/

     &    (ei**2*vint(111)*ef**2+ei*vi*vint(112)*ef*vf+

     &    ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*

     &    (vf**2+af**2)+(vi*vpi+ai*api)*vint(115)*(vf*vpf+af*apf)+

     &    (vpi**2+api**2)*vint(116)*(vpf**2+apf**2))

          wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2

          wtmax=2d0+abs(asym)

        ELSEIF(ip.EQ.1.AND.iabs(kfl1(1)).EQ.24) THEN

C...Angular weight for f + fbar -> Z' -> W+ + W-.

          rm1=p(nsd(1)+1,5)**2/sh

          rm2=p(nsd(1)+2,5)**2/sh

          ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*

     &    (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)

          cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+

     &    (rm2-rm1)**2)

          wt=cflat+ccos2*cthe(1)**2

          wtmax=cflat+max(0d0,ccos2)

        ELSEIF(ip.EQ.1.AND.(kfl1(1).EQ.25.OR.kfl1(1).EQ.35.OR.

     &    iabs(kfl1(1)).EQ.37)) THEN

C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.

          wt=1d0-cthe(1)**2

          wtmax=1d0

        ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN

C...Angular weight for f + fbar -> Z' -> Z0 + h0.

          rm1=p(nsd(1)+1,5)**2/sh

          rm2=p(nsd(1)+2,5)**2/sh

          flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)

          wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)

          wtmax=1d0+flam2/(8d0*rm1)

        ELSEIF(mzpwp.EQ.0) THEN

C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons

C...(W:s like if intermediate Z).

          d34=p(iref(ip,iord),5)**2

          d56=p(iref(ip,3-iord),5)**2

          dt=pkk(1,3)+pkk(1,4)+d34

          du=pkk(1,5)+pkk(1,6)+d56

          fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))

          fgk253=abs(fgk(2,1,5,6,3,4)-fgk(2,1,3,4,5,6))

          wt=(coup(1,3)*fgk135)**2+(coup(1,4)*fgk253)**2

          wtmax=4d0*d34*d56*(coup(1,3)**2+coup(1,4)**2)*

     &    (digk(dt,du)+digk(du,dt)-djgk(dt,du))

        ELSEIF(mzpwp.EQ.1) THEN

C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons

C...(W:s approximately longitudinal, like if intermediate H).

          wt=16d0*pkk(3,5)*pkk(4,6)

          wtmax=sh**2

        ELSE

C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,

C...H0 + A0 -> 4 quarks/leptons.

          wt=1d0

          wtmax=1d0

        ENDIF


      ELSEIF(isub.EQ.142) THEN

        IF(ip.EQ.1.AND.iabs(kfl1(1)).LT.20) THEN

C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.

          kfai=iabs(mint(15))

          kfaic=1

          IF(kfai.GT.10) kfaic=2

          vi=paru(129+2*kfaic)

          ai=paru(130+2*kfaic)

          kfaf=iabs(kfl1(1))

          kfafc=1

          IF(kfaf.GT.10) kfafc=2

          vf=paru(129+2*kfafc)

          af=paru(130+2*kfafc)

          asym=8d0*vi*ai*vf*af/((vi**2+ai**2)*(vf**2+af**2))

          wt=1d0+asym*cthe(1)*isign(1,mint(15)*kfl1(1))+cthe(1)**2

          wtmax=2d0+abs(asym)

        ELSEIF(ip.EQ.1.AND.iabs(kfl2(1)).EQ.23) THEN

C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.

          rm1=p(nsd(1)+1,5)**2/sh

          rm2=p(nsd(1)+2,5)**2/sh

          ccos2=-(1d0/16d0)*((1d0-rm1-rm2)**2-4d0*rm1*rm2)*

     &    (1d0-2d0*rm1-2d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)

          cflat=-ccos2+0.5d0*(rm1+rm2)*(1d0-2d0*rm1-2d0*rm2+

     &    (rm2-rm1)**2)

          wt=cflat+ccos2*cthe(1)**2

          wtmax=cflat+max(0d0,ccos2)

        ELSEIF(ip.EQ.1.AND.kfl2(1).EQ.25) THEN

C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.

          rm1=p(nsd(1)+1,5)**2/sh

          rm2=p(nsd(1)+2,5)**2/sh

          flam2=max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2)

          wt=1d0+flam2*(1d0-cthe(1)**2)/(8d0*rm1)

          wtmax=1d0+flam2/(8d0*rm1)

        ELSEIF(mzpwp.EQ.0) THEN

C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons

C...(W/Z like if intermediate W).

          d34=p(iref(ip,iord),5)**2

          d56=p(iref(ip,3-iord),5)**2

          dt=pkk(1,3)+pkk(1,4)+d34

          du=pkk(1,5)+pkk(1,6)+d56

          fgk135=abs(fgk(1,2,3,4,5,6)-fgk(1,2,5,6,3,4))

          fgk136=abs(fgk(1,2,3,4,6,5)-fgk(1,2,6,5,3,4))

          wt=(coup(5,3)*fgk135)**2+(coup(5,4)*fgk136)**2

          wtmax=4d0*d34*d56*(coup(5,3)**2+coup(5,4)**2)*

     &    (digk(dt,du)+digk(du,dt)-djgk(dt,du))

        ELSEIF(mzpwp.EQ.1) THEN

C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons

C...(W/Z approximately longitudinal, like if intermediate H).

          wt=16d0*pkk(3,5)*pkk(4,6)

          wtmax=sh**2

        ELSE

C...Angular weight for f + fbar -> W' -> W + h0 -> whatever.

          wt=1d0

          wtmax=1d0

        ENDIF


      ELSEIF(isub.EQ.145.OR.isub.EQ.162.OR.isub.EQ.163.OR.isub.EQ.164)

     &  THEN

C...Isotropic decay of leptoquarks (assumed spin 0).

        wt=1d0

        wtmax=1d0


      ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN

C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-).

        side=1d0

        IF(mint(16).EQ.21) side=-1d0

        IF(ip.EQ.1.AND.(kfl1(1).EQ.21.OR.kfl1(1).EQ.22)) THEN

          wt=1d0+side*cthe(1)

          wtmax=2d0

        ELSEIF(ip.EQ.1) THEN

          rm1=p(nsd(1)+1,5)**2/sh

          wt=1d0+side*cthe(1)*(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)

          wtmax=1d0+(1d0-0.5d0*rm1)/(1d0+0.5d0*rm1)

        ELSE

C...W/Z decay assumed isotropic, since not known.

          wt=1d0

          wtmax=1d0

        ENDIF


      ELSEIF(isub.EQ.149) THEN

C...Isotropic decay of techni-eta.

        wt=1d0

        wtmax=1d0


      ELSEIF(isub.EQ.191) THEN

        IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN

C...Angular weight for f + fbar -> rho_tech0 -> W+ W-,

C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-.

          wt=1d0-cthe(1)**2

          wtmax=1d0

        ELSEIF(ip.EQ.1) THEN

C...Angular weight for f + fbar -> rho_tech0 -> f fbar.

          cthesg=cthe(1)*isign(1,mint(15))

          xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))

          bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

          bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)

          kfai=iabs(mint(15))

          ei=kchg(kfai,1)/3d0

          ai=sign(1d0,ei+0.1d0)

          vi=ai-4d0*ei*xwv

          vali=0.5d0*(vi+ai)

          vari=0.5d0*(vi-ai)

          alefti=(ei+vali*bwzr)**2+(vali*bwzi)**2

          arighi=(ei+vari*bwzr)**2+(vari*bwzi)**2

          kfaf=iabs(kfl1(1))

          ef=kchg(kfaf,1)/3d0

          af=sign(1d0,ef+0.1d0)

          vf=af-4d0*ef*xwv

          valf=0.5d0*(vf+af)

          varf=0.5d0*(vf-af)

          aleftf=(ef+valf*bwzr)**2+(valf*bwzi)**2

          arighf=(ef+varf*bwzr)**2+(varf*bwzi)**2

          asame=alefti*aleftf+arighi*arighf

          aflip=alefti*arighf+arighi*aleftf

          wt=asame*(1d0+cthesg)**2+aflip*(1d0-cthesg)**2

          wtmax=4d0*max(asame,aflip)

        ELSE

C...Isotropic decay of W/pi_tech produced in rho_tech decay.

          wt=1d0

          wtmax=1d0

        ENDIF


      ELSEIF(isub.EQ.192) THEN

        IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN

C...Angular weight for f + fbar' -> rho_tech+ -> W+ Z0,

C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0.

          wt=1d0-cthe(1)**2

          wtmax=1d0

        ELSEIF(ip.EQ.1) THEN

C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'.

          cthesg=cthe(1)*isign(1,mint(15))

          wt=(1d0+cthesg)**2

          wtmax=4d0

        ELSE

C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ decay.

          wt=1d0

          wtmax=1d0

        ENDIF


      ELSEIF(isub.EQ.193) THEN

        IF(ip.EQ.1.AND.iabs(kfl1(1)).GT.21) THEN

C...Angular weight for f + fbar -> omega_tech0 ->

C...gamma pi_tech0 or Z0 pi_tech0.

          wt=1d0+cthe(1)**2

          wtmax=2d0

        ELSEIF(ip.EQ.1) THEN

C...Angular weight for f + fbar -> omega_tech0 -> f fbar.

          cthesg=cthe(1)*isign(1,mint(15))

          bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

          bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)

          kfai=iabs(mint(15))

          ei=kchg(kfai,1)/3d0

          ai=sign(1d0,ei+0.1d0)

          vi=ai-4d0*ei*xwv

          vali=0.5d0*(vi+ai)

          vari=0.5d0*(vi-ai)

          blefti=(ei-vali*bwzr)**2+(vali*bwzi)**2

          brighi=(ei-vari*bwzr)**2+(vari*bwzi)**2

          kfaf=iabs(kfl1(1))

          ef=kchg(kfaf,1)/3d0

          af=sign(1d0,ef+0.1d0)

          vf=af-4d0*ef*xwv

          valf=0.5d0*(vf+af)

          varf=0.5d0*(vf-af)

          bleftf=(ef-valf*bwzr)**2+(valf*bwzi)**2

          brighf=(ef-varf*bwzr)**2+(varf*bwzi)**2

          bsame=blefti*bleftf+brighi*brighf

          bflip=blefti*brighf+brighi*bleftf

          wt=bsame*(1d0+cthesg)**2+bflip*(1d0-cthesg)**2

          wtmax=4d0*max(bsame,bflip)

        ELSE

C...Isotropic decay of Z/pi_tech produced in omega_tech decay.

          wt=1d0

          wtmax=1d0

        ENDIF


C...Obtain correct angular distribution by rejection techniques.

      ELSE

        wt=1d0

        wtmax=1d0

      ENDIF

      IF(wt.LT.pyr(0)*wtmax) goto 310


C...Construct massive four-vectors using angles chosen.

  470 DO 540 jt=1,jtmax

        IF(kdcy(jt).EQ.0) goto 540

        id=iref(ip,jt)

        DO 480 j=1,5

          dpmo(j)=p(id,j)

  480   CONTINUE

        dpmo(4)=sqrt(dpmo(1)**2+dpmo(2)**2+dpmo(3)**2+dpmo(5)**2)

CMRENNA++

        IF(kfl3(jt).EQ.0) THEN

          CALL pyrobo(nsd(jt)+1,nsd(jt)+2,acos(cthe(jt)),phi(jt),

     &    dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))

        ELSE

          CALL pyrobo(nsd(jt)+1,nsd(jt)+3,acos(cthe(jt)),phi(jt),

     &    dpmo(1)/dpmo(4),dpmo(2)/dpmo(4),dpmo(3)/dpmo(4))

        ENDIF

CMRENNA--


C...Mark decayed resonances; trace history.

        k(id,1)=k(id,1)+10

        kfa=iabs(k(id,2))

        kca=pycomp(kfa)

        IF(kcqm(jt).NE.0) THEN

C...Do not kill colour flow through coloured resonance!

        ELSE

          k(id,4)=nsd(jt)+1

          k(id,5)=nsd(jt)+2

          IF(kfl3(jt).NE.0) k(id,5)=nsd(jt)+3

        ENDIF


C...Add documentation lines.

        IF(isub.NE.0) THEN

          idoc=mint(83)+mint(4)

CMRENNA+++

          ihi=nsd(jt)+2

          IF(kfl3(jt).NE.0) ihi=ihi+1

          DO 500 i=nsd(jt)+1,ihi

CMRENNA---

            i1=mint(83)+mint(4)+1

            k(i,3)=i1

            IF(mstp(128).GE.1) k(i,3)=id

            IF(mstp(128).LE.1.AND.mint(4).LT.mstp(126)) THEN

              mint(4)=mint(4)+1

              k(i1,1)=21

              k(i1,2)=k(i,2)

              k(i1,3)=iref(ip,jt+3)

              DO 490 j=1,5

                p(i1,j)=p(i,j)

  490         CONTINUE

            ENDIF

  500     CONTINUE

        ELSE

          k(i,3)=id

        ENDIF


C...Do showering if any of the two/three products can shower.

        nshbef=n

        IF(mstp(71).GE.1) THEN

          ishow1=0

          kfl1a=iabs(kfl1(jt))

          IF(kfl1a.LE.22) ishow1=1

          ishow2=0

          kfl2a=iabs(kfl2(jt))

          IF(kfl2a.LE.22) ishow2=1

          ishow3=0

          IF(kfl3(jt).NE.0) THEN

            kfl3a=iabs(kfl3(jt))

            IF(kfl3a.LE.22) ishow3=1

          ENDIF

          IF(ishow1.EQ.0.AND.ishow2.EQ.0.AND.ishow3.EQ.0) THEN

          ELSEIF(kfl3(jt).EQ.0) THEN

            CALL pyshow(nsd(jt)+1,nsd(jt)+2,p(id,5))

          ELSE

            nsd1=nsd(jt)+1

            nsd2=nsd(jt)+2

            IF(ishow1.EQ.0.AND.ishow3.NE.0) THEN

              nsd1=nsd(jt)+3

            ELSEIF(ishow2.EQ.0.AND.ishow3.NE.0) THEN

              nsd2=nsd(jt)+3

            ENDIF

            pmshow=sqrt(max(0d0,(p(nsd1,4)+p(nsd2,4))**2-

     &      (p(nsd1,1)+p(nsd2,1))**2-(p(nsd1,2)+p(nsd2,2))**2-

     &      (p(nsd1,3)+p(nsd2,3))**2))

            CALL pyshow(nsd1,nsd2,pmshow)

          ENDIF

        ENDIF

        nshaft=n

        IF(jt.EQ.1) naft1=n


C...Check if decay products moved by shower.

        nsd1=nsd(jt)+1

        nsd2=nsd(jt)+2

        nsd3=nsd(jt)+3

        IF(nshaft.GT.nshbef) THEN

          IF(k(nsd1,1).GT.10) THEN

            DO 510 i=nshbef+1,nshaft

              IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd1,2)) nsd1=i

  510       CONTINUE

          ENDIF

          IF(k(nsd2,1).GT.10) THEN

            DO 520 i=nshbef+1,nshaft

              IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd2,2).AND.

     &        i.NE.nsd1) nsd2=i

  520       CONTINUE

          ENDIF

          IF(kfl3(jt).NE.0.AND.k(nsd3,1).GT.10) THEN

            DO 530 i=nshbef+1,nshaft

              IF(k(i,1).LT.10.AND.k(i,2).EQ.k(nsd3,2).AND.

     &        i.NE.nsd1.AND.i.NE.nsd2) nsd3=i

  530       CONTINUE

          ENDIF

        ENDIF


C...Store decay products for further treatment.

        np=np+1

        iref(np,1)=nsd1

        iref(np,2)=nsd2

        iref(np,3)=0

        IF(kfl3(jt).NE.0) iref(np,3)=nsd3

        iref(np,4)=idoc+1

        iref(np,5)=idoc+2

        iref(np,6)=0

        IF(kfl3(jt).NE.0) iref(np,6)=idoc+3

        iref(np,7)=k(iref(ip,jt),2)

        iref(np,8)=iref(ip,jt)

  540 CONTINUE


C...Fill information for 2 -> 1 -> 2.

  550 IF(jtmax.EQ.1.AND.kdcy(1).NE.0.AND.isub.NE.0) THEN

        mint(7)=mint(83)+6+2*iset(isub)

        mint(8)=mint(83)+7+2*iset(isub)

        mint(25)=kfl1(1)

        mint(26)=kfl2(1)

        vint(23)=cthe(1)

        rm3=p(n-1,5)**2/sh

        rm4=p(n,5)**2/sh

        be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))

        vint(45)=-0.5d0*sh*(1d0-rm3-rm4-be34*cthe(1))

        vint(46)=-0.5d0*sh*(1d0-rm3-rm4+be34*cthe(1))

        vint(48)=0.25d0*sh*be34**2*max(0d0,1d0-cthe(1)**2)

        vint(47)=sqrt(vint(48))

      ENDIF


C...Possibility of colour rearrangement in W+W- events.

      IF(isub.EQ.25.AND.mstp(115).GE.1) THEN

        iakf1=iabs(kfl1(1))

        iakf2=iabs(kfl1(2))

        iakf3=iabs(kfl2(1))

        iakf4=iabs(kfl2(2))

        IF(min(iakf1,iakf2,iakf3,iakf4).GE.1.AND.

     &  max(iakf1,iakf2,iakf3,iakf4).LE.5) CALL

     &  pyreco(iref(1,1),iref(1,2),nsd(1),naft1)

      ENDIF


C...Loop back if needed.

  560 IF(ip.LT.np) goto 130


      RETURN

      END


C*********************************************************************


C...PYMULT

C...Initializes treatment of multiple interactions, selects kinematics

C...of hardest interaction if low-pT physics included in run, and

C...generates all non-hardest interactions.


      SUBROUTINE pymult(MMUL)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint7/sigt(0:6,0:6,0:5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint3/,/pyint5/,/pyint7/

C...Local arrays and saved variables.

      dimension nmul(20),sigm(20),kstr(500,2),vintsv(80)

      SAVE xt2,xt2fac,xc2,xts,irbin,rbin,nmul,sigm


C...Initialization of multiple interaction treatment.

      IF(mmul.EQ.1) THEN

        IF(mstp(122).GE.1) WRITE(mstu(11),5000) mstp(82)

        isub=96

        mint(1)=96

        vint(63)=0d0

        vint(64)=0d0

        vint(143)=1d0

        vint(144)=1d0


C...Loop over phase space points: xT2 choice in 20 bins.

  100   sigsum=0d0

        DO 120 ixt2=1,20

          nmul(ixt2)=mstp(83)

          sigm(ixt2)=0d0

          DO 110 itry=1,mstp(83)

            rsca=0.05d0*((21-ixt2)-pyr(0))

            xt2=vint(149)*(1d0+vint(149))/(vint(149)+rsca)-vint(149)

            xt2=max(0.01d0*vint(149),xt2)

            vint(25)=xt2


C...Choose tau and y*. Calculate cos(theta-hat).

            IF(pyr(0).LE.coef(isub,1)) THEN

              taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)

              tau=xt2*(1d0+taut)**2/(4d0*taut)

            ELSE

              tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)

            ENDIF

            vint(21)=tau

            CALL pyklim(2)

            ryst=pyr(0)

            myst=1

            IF(ryst.GT.coef(isub,8)) myst=2

            IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3

            CALL pykmap(2,myst,pyr(0))

            vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))


C...Calculate differential cross-section.

            vint(71)=0.5d0*vint(1)*sqrt(xt2)

            CALL pysigh(nchn,sigs)

            sigm(ixt2)=sigm(ixt2)+sigs

  110     CONTINUE

          sigsum=sigsum+sigm(ixt2)

  120   CONTINUE

        sigsum=sigsum/(20d0*mstp(83))


C...Reject result if sigma(parton-parton) is smaller than hadronic one.

        IF(sigsum.LT.1.1d0*sigt(0,0,5)) THEN

          IF(mstp(122).GE.1) WRITE(mstu(11),5100) parp(82),sigsum

          parp(82)=0.9d0*parp(82)

          vint(149)=4d0*parp(82)**2/vint(2)

          goto 100

        ENDIF

        IF(mstp(122).GE.1) WRITE(mstu(11),5200) parp(82), sigsum


C...Start iteration to find k factor.

        yke=sigsum/sigt(0,0,5)

        so=0.5d0

        xi=0d0

        yi=0d0

        xf=0d0

        yf=0d0

        xk=0.5d0

        iit=0

  130   IF(iit.EQ.0) THEN

          xk=2d0*xk

        ELSEIF(iit.EQ.1) THEN

          xk=0.5d0*xk

        ELSE

          xk=xi+(yke-yi)*(xf-xi)/(yf-yi)

        ENDIF


C...Evaluate overlap integrals.

        IF(mstp(82).EQ.2) THEN

          sp=0.5d0*paru(1)*(1d0-exp(-xk))

          sop=sp/paru(1)

        ELSE

          IF(mstp(82).EQ.3) deltab=0.02d0

          IF(mstp(82).EQ.4) deltab=min(0.01d0,0.05d0*parp(84))

          sp=0d0

          sop=0d0

          b=-0.5d0*deltab

  140     b=b+deltab

          IF(mstp(82).EQ.3) THEN

            ov=exp(-b**2)/paru(2)

          ELSE

            cq2=parp(84)**2

            ov=((1d0-parp(83))**2*exp(-min(50d0,b**2))+

     &      2d0*parp(83)*(1d0-parp(83))*2d0/(1d0+cq2)*

     &      exp(-min(50d0,b**2*2d0/(1d0+cq2)))+

     &      parp(83)**2/cq2*exp(-min(50d0,b**2/cq2)))/paru(2)

          ENDIF

          pacc=1d0-exp(-min(50d0,paru(1)*xk*ov))

          sp=sp+paru(2)*b*deltab*pacc

          sop=sop+paru(2)*b*deltab*ov*pacc

          IF(b.LT.1d0.OR.b*pacc.GT.1d-6) goto 140

        ENDIF

        yk=paru(1)*xk*so/sp


C...Continue iteration until convergence.

        IF(yk.LT.yke) THEN

          xi=xk

          yi=yk

          IF(iit.EQ.1) iit=2

        ELSE

          xf=xk

          yf=yk

          IF(iit.EQ.0) iit=1

        ENDIF

        IF(abs(yk-yke).GE.1d-5*yke) goto 130


C...Store some results for subsequent use.

        vint(145)=sigsum

        vint(146)=sop/so

        vint(147)=sop/sp


C...Initialize iteration in xT2 for hardest interaction.

      ELSEIF(mmul.EQ.2) THEN

        IF(mstp(82).LE.0) THEN

        ELSEIF(mstp(82).EQ.1) THEN

          xt2=1d0

          xt2fac=xsec(96,1)/sigt(0,0,5)*vint(149)/(1d0-vint(149))

        ELSEIF(mstp(82).EQ.2) THEN

          xt2=1d0

          xt2fac=vint(146)*xsec(96,1)/sigt(0,0,5)*vint(149)*

     &    (1d0+vint(149))

        ELSE

          xc2=4d0*ckin(3)**2/vint(2)

          IF(ckin(3).LE.ckin(5).OR.mint(82).GE.2) xc2=0d0

        ENDIF


      ELSEIF(mmul.EQ.3) THEN

C...Low-pT or multiple interactions (first semihard interaction):

C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)

C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).

        isub=mint(1)

        IF(mstp(82).LE.0) THEN

          xt2=0d0

        ELSEIF(mstp(82).EQ.1) THEN

          xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))

        ELSEIF(mstp(82).EQ.2) THEN

          IF(xt2.LT.1d0.AND.exp(-xt2fac*xt2/(vint(149)*(xt2+

     &    vint(149)))).GT.pyr(0)) xt2=1d0

          IF(xt2.GE.1d0) THEN

            xt2=(1d0+vint(149))*xt2fac/(xt2fac-(1d0+vint(149))*log(1d0-

     &      pyr(0)*(1d0-exp(-xt2fac/(vint(149)*(1d0+vint(149)))))))-

     &      vint(149)

          ELSE

            xt2=-xt2fac/log(exp(-xt2fac/(xt2+vint(149)))+pyr(0)*

     &      (exp(-xt2fac/vint(149))-exp(-xt2fac/(xt2+vint(149)))))-

     &      vint(149)

          ENDIF

          xt2=max(0.01d0*vint(149),xt2)

        ELSE

          xt2=(xc2+vint(149))*(1d0+vint(149))/(1d0+vint(149)-

     &    pyr(0)*(1d0-xc2))-vint(149)

          xt2=max(0.01d0*vint(149),xt2)

        ENDIF

        vint(25)=xt2


C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.

        IF(mstp(82).LE.1.AND.xt2.LT.vint(149)) THEN

          IF(mint(82).EQ.1) ngen(0,1)=ngen(0,1)-1

          IF(mint(82).EQ.1) ngen(isub,1)=ngen(isub,1)-1

          isub=95

          mint(1)=isub

          vint(21)=0.01d0*vint(149)

          vint(22)=0d0

          vint(23)=0d0

          vint(25)=0.01d0*vint(149)


        ELSE

C...Multiple interactions (first semihard interaction).

C...Choose tau and y*. Calculate cos(theta-hat).

          IF(pyr(0).LE.coef(isub,1)) THEN

            taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)

            tau=xt2*(1d0+taut)**2/(4d0*taut)

          ELSE

            tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)

          ENDIF

          vint(21)=tau

          CALL pyklim(2)

          ryst=pyr(0)

          myst=1

          IF(ryst.GT.coef(isub,8)) myst=2

          IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3

          CALL pykmap(2,myst,pyr(0))

          vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))

        ENDIF

        vint(71)=0.5d0*vint(1)*sqrt(vint(25))


C...Store results of cross-section calculation.

      ELSEIF(mmul.EQ.4) THEN

        isub=mint(1)

        xts=vint(25)

        IF(iset(isub).EQ.1) xts=vint(21)

        IF(iset(isub).EQ.2)

     &  xts=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)

        IF(iset(isub).GE.3.AND.iset(isub).LE.5) xts=vint(26)

        rbin=max(0.000001d0,min(0.999999d0,xts*(1d0+vint(149))/

     &  (xts+vint(149))))

        irbin=int(1d0+20d0*rbin)

        IF(isub.EQ.96.AND.mstp(171).EQ.0) THEN

          nmul(irbin)=nmul(irbin)+1

          sigm(irbin)=sigm(irbin)+vint(153)

        ENDIF


C...Choose impact parameter.

      ELSEIF(mmul.EQ.5) THEN

        IF(mstp(82).EQ.3) THEN

          vint(148)=pyr(0)/(paru(2)*vint(147))

        ELSE

          rtype=pyr(0)

          cq2=parp(84)**2

          IF(rtype.LT.(1d0-parp(83))**2) THEN

            b2=-log(pyr(0))

          ELSEIF(rtype.LT.1d0-parp(83)**2) THEN

            b2=-0.5d0*(1d0+cq2)*log(pyr(0))

          ELSE

            b2=-cq2*log(pyr(0))

          ENDIF

          vint(148)=((1d0-parp(83))**2*exp(-min(50d0,b2))+2d0*parp(83)*

     &    (1d0-parp(83))*2d0/(1d0+cq2)*exp(-min(50d0,b2*2d0/(1d0+cq2)))+

     &    parp(83)**2/cq2*exp(-min(50d0,b2/cq2)))/(paru(2)*vint(147))

        ENDIF


C...Multiple interactions (variable impact parameter) : reject with

C...probability exp(-overlap*cross-section above pT/normalization).

        rncor=(irbin-20d0*rbin)*nmul(irbin)

        sigcor=(irbin-20d0*rbin)*sigm(irbin)

        DO 150 ibin=irbin+1,20

          rncor=rncor+nmul(ibin)

          sigcor=sigcor+sigm(ibin)

  150   CONTINUE

        sigabv=(sigcor/rncor)*vint(149)*(1d0-xts)/(xts+vint(149))

        IF(mstp(171).EQ.1) sigabv=sigabv*vint(2)/vint(289)

        vint(150)=exp(-min(50d0,vint(146)*vint(148)*

     &  sigabv/sigt(0,0,5)))


C...Generate additional multiple semihard interactions.

      ELSEIF(mmul.EQ.6) THEN

        isubsv=mint(1)

        DO 160 j=11,80

          vintsv(j)=vint(j)

  160   CONTINUE

        isub=96

        mint(1)=96


C...Reconstruct strings in hard scattering.

        nmax=mint(84)+4

        IF(iset(isubsv).EQ.1) nmax=mint(84)+2

        IF(iset(isubsv).EQ.11) nmax=mint(84)+2+mint(3)

        nstr=0

        DO 180 i=mint(84)+1,nmax

          kcs=kchg(pycomp(k(i,2)),2)*isign(1,k(i,2))

          IF(kcs.EQ.0) goto 180


          DO 170 j=1,4

            IF(kcs.EQ.1.AND.(j.EQ.2.OR.j.EQ.4)) goto 170

            IF(kcs.EQ.-1.AND.(j.EQ.1.OR.j.EQ.3)) goto 170

            IF(j.LE.2) THEN

              ist=mod(k(i,j+3)/mstu(5),mstu(5))

            ELSE

              ist=mod(k(i,j+1),mstu(5))

            ENDIF

            IF(ist.LT.mint(84).OR.ist.GT.i) goto 170

            IF(kchg(pycomp(k(ist,2)),2).EQ.0) goto 170

            nstr=nstr+1

            IF(j.EQ.1.OR.j.EQ.4) THEN

              kstr(nstr,1)=i

              kstr(nstr,2)=ist

            ELSE

              kstr(nstr,1)=ist

              kstr(nstr,2)=i

            ENDIF

  170     CONTINUE

  180   CONTINUE


C...Set up starting values for iteration in xT2.

        xt2=vint(25)

        IF(iset(isubsv).EQ.1) xt2=vint(21)

        IF(iset(isubsv).EQ.2)

     &  xt2=(4d0*vint(48)+2d0*vint(63)+2d0*vint(64))/vint(2)

        IF(iset(isubsv).GE.3.AND.iset(isubsv).LE.5) xt2=vint(26)

        IF(mstp(82).LE.1) THEN

          xt2fac=xsec(isub,1)*vint(149)/((1d0-vint(149))*sigt(0,0,5))

        ELSE

          xt2fac=vint(146)*vint(148)*xsec(isub,1)/sigt(0,0,5)*

     &    vint(149)*(1d0+vint(149))

        ENDIF

        vint(63)=0d0

        vint(64)=0d0

        vint(143)=1d0-vint(141)

        vint(144)=1d0-vint(142)


C...Iterate downwards in xT2.

  190   IF(mstp(82).LE.1) THEN

          xt2=xt2fac*xt2/(xt2fac-xt2*log(pyr(0)))

          IF(xt2.LT.vint(149)) goto 240

        ELSE

          IF(xt2.LE.0.01001d0*vint(149)) goto 240

          xt2=xt2fac*(xt2+vint(149))/(xt2fac-(xt2+vint(149))*

     &    log(pyr(0)))-vint(149)

          IF(xt2.LE.0d0) goto 240

          xt2=max(0.01d0*vint(149),xt2)

        ENDIF

        vint(25)=xt2


C...Choose tau and y*. Calculate cos(theta-hat).

        IF(pyr(0).LE.coef(isub,1)) THEN

          taut=(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)**pyr(0)

          tau=xt2*(1d0+taut)**2/(4d0*taut)

        ELSE

          tau=xt2*(1d0+tan(pyr(0)*atan(sqrt(1d0/xt2-1d0)))**2)

        ENDIF

        vint(21)=tau

        CALL pyklim(2)

        ryst=pyr(0)

        myst=1

        IF(ryst.GT.coef(isub,8)) myst=2

        IF(ryst.GT.coef(isub,8)+coef(isub,9)) myst=3

        CALL pykmap(2,myst,pyr(0))

        vint(23)=sqrt(max(0d0,1d0-xt2/tau))*(-1)**int(1.5d0+pyr(0))


C...Check that x not used up. Accept or reject kinematical variables.

        x1m=sqrt(tau)*exp(vint(22))

        x2m=sqrt(tau)*exp(-vint(22))

        IF(vint(143)-x1m.LT.0.01d0.OR.vint(144)-x2m.LT.0.01d0) goto 190

        vint(71)=0.5d0*vint(1)*sqrt(xt2)

        CALL pysigh(nchn,sigs)

        IF(sigs.LT.xsec(isub,1)*pyr(0)) goto 190


C...Reset K, P and V vectors. Select some variables.

        DO 210 i=n+1,n+2

          DO 200 j=1,5

            k(i,j)=0

            p(i,j)=0d0

            v(i,j)=0d0

  200     CONTINUE

  210   CONTINUE

        rflav=pyr(0)

        pt=0.5d0*vint(1)*sqrt(xt2)

        phi=paru(2)*pyr(0)

        cth=vint(23)


C...Add first parton to event record.

        k(n+1,1)=3

        k(n+1,2)=21

        IF(rflav.GE.max(parp(85),parp(86))) k(n+1,2)=

     &  1+int((2d0+parj(2))*pyr(0))

        p(n+1,1)=pt*cos(phi)

        p(n+1,2)=pt*sin(phi)

        p(n+1,3)=0.25d0*vint(1)*(vint(41)*(1d0+cth)-vint(42)*(1d0-cth))

        p(n+1,4)=0.25d0*vint(1)*(vint(41)*(1d0+cth)+vint(42)*(1d0-cth))

        p(n+1,5)=0d0


C...Add second parton to event record.

        k(n+2,1)=3

        k(n+2,2)=21

        IF(k(n+1,2).NE.21) k(n+2,2)=-k(n+1,2)

        p(n+2,1)=-p(n+1,1)

        p(n+2,2)=-p(n+1,2)

        p(n+2,3)=0.25d0*vint(1)*(vint(41)*(1d0-cth)-vint(42)*(1d0+cth))

        p(n+2,4)=0.25d0*vint(1)*(vint(41)*(1d0-cth)+vint(42)*(1d0+cth))

        p(n+2,5)=0d0


        IF(rflav.LT.parp(85).AND.nstr.GE.1) THEN

C....Choose relevant string pieces to place gluons on.

          DO 230 i=n+1,n+2

            dmin=1d8

            DO 220 istr=1,nstr

              i1=kstr(istr,1)

              i2=kstr(istr,2)

              dist=(p(i,4)*p(i1,4)-p(i,1)*p(i1,1)-p(i,2)*p(i1,2)-

     &        p(i,3)*p(i1,3))*(p(i,4)*p(i2,4)-p(i,1)*p(i2,1)-

     &        p(i,2)*p(i2,2)-p(i,3)*p(i2,3))/max(1d0,p(i1,4)*p(i2,4)-

     &        p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-p(i1,3)*p(i2,3))

              IF(istr.EQ.1.OR.dist.LT.dmin) THEN

                dmin=dist

                ist1=i1

                ist2=i2

                istm=istr

              ENDIF

  220       CONTINUE


C....Colour flow adjustments, new string pieces.

            IF(k(ist1,4)/mstu(5).EQ.ist2) k(ist1,4)=mstu(5)*i+

     &      mod(k(ist1,4),mstu(5))

            IF(mod(k(ist1,5),mstu(5)).EQ.ist2) k(ist1,5)=

     &      mstu(5)*(k(ist1,5)/mstu(5))+i

            k(i,5)=mstu(5)*ist1

            k(i,4)=mstu(5)*ist2

            IF(k(ist2,5)/mstu(5).EQ.ist1) k(ist2,5)=mstu(5)*i+

     &      mod(k(ist2,5),mstu(5))

            IF(mod(k(ist2,4),mstu(5)).EQ.ist1) k(ist2,4)=

     &      mstu(5)*(k(ist2,4)/mstu(5))+i

            kstr(istm,2)=i

            kstr(nstr+1,1)=i

            kstr(nstr+1,2)=ist2

            nstr=nstr+1

  230     CONTINUE


C...String drawing and colour flow for gluon loop.

        ELSEIF(k(n+1,2).EQ.21) THEN

          k(n+1,4)=mstu(5)*(n+2)

          k(n+1,5)=mstu(5)*(n+2)

          k(n+2,4)=mstu(5)*(n+1)

          k(n+2,5)=mstu(5)*(n+1)

          kstr(nstr+1,1)=n+1

          kstr(nstr+1,2)=n+2

          kstr(nstr+2,1)=n+2

          kstr(nstr+2,2)=n+1

          nstr=nstr+2


C...String drawing and colour flow for qqbar pair.

        ELSE

          k(n+1,4)=mstu(5)*(n+2)

          k(n+2,5)=mstu(5)*(n+1)

          kstr(nstr+1,1)=n+1

          kstr(nstr+1,2)=n+2

          nstr=nstr+1

        ENDIF


C...Update remaining energy; iterate.

        n=n+2

        IF(n.GT.mstu(4)-mstu(32)-10) THEN

          CALL pyerrm(11,'(PYMULT:) no more memory left in PYJETS')

          IF(mstu(21).GE.1) RETURN

        ENDIF

        mint(31)=mint(31)+1

        vint(151)=vint(151)+vint(41)

        vint(152)=vint(152)+vint(42)

        vint(143)=vint(143)-vint(41)

        vint(144)=vint(144)-vint(42)

        IF(mint(31).LT.240) goto 190

  240   CONTINUE

        mint(1)=isubsv

        DO 250 j=11,80

          vint(j)=vintsv(j)

  250   CONTINUE

      ENDIF


C...Format statements for printout.

 5000 FORMAT(/1x,'****** PYMULT: initialization of multiple inter',

     &'actions for MSTP(82) =',i2,' ******')

 5100 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,

     &d9.2,' mb: rejected')

 5200 FORMAT(8x,'pT0 =',f5.2,' GeV gives sigma(parton-parton) =',1p,

     &d9.2,' mb: accepted')


      RETURN

      END


C*********************************************************************


C...PYREMN

C...Adds on target remnants (one or two from each side) and

C...includes primordial kT for hadron beams.


      SUBROUTINE pyremn(IPU1,IPU2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/

C...Local arrays.

      dimension kflch(2),kflsp(2),chi(2),pms(0:6),is(2),isn(2),robo(5),

     &psys(0:2,5),pmin(0:2),qold(4),qnew(4),dbe(3),psum(4)


C...Find event type and remaining energy.

      isub=mint(1)

      ns=n

      IF(mint(50).EQ.0.OR.mstp(81).LE.0) THEN

        vint(143)=1d0-vint(141)

        vint(144)=1d0-vint(142)

      ENDIF


C...Define initial partons.

      ntry=0

  100 ntry=ntry+1

      DO 130 jt=1,2

        i=mint(83)+jt+2

        IF(jt.EQ.1) ipu=ipu1

        IF(jt.EQ.2) ipu=ipu2

        k(i,1)=21

        k(i,2)=k(ipu,2)

        k(i,3)=i-2

        pms(jt)=0d0

        vint(156+jt)=0d0

        vint(158+jt)=0d0

        IF(mint(47).EQ.1) THEN

          DO 110 j=1,5

            p(i,j)=p(i-2,j)

  110     CONTINUE

        ELSEIF(isub.EQ.95) THEN

          k(i,2)=21

        ELSE

          p(i,5)=p(ipu,5)


C...No primordial kT, or chosen according to truncated Gaussian or

C...exponential, or (for photon) predetermined or power law.

  120     IF(mint(40+jt).EQ.2.AND.mint(10+jt).NE.22) THEN

            IF(mstp(91).LE.0) THEN

              pt=0d0

            ELSEIF(mstp(91).EQ.1) THEN

              pt=parp(91)*sqrt(-log(pyr(0)))

            ELSE

              rpt1=pyr(0)

              rpt2=pyr(0)

              pt=-parp(92)*log(rpt1*rpt2)

            ENDIF

            IF(pt.GT.parp(93)) goto 120

          ELSEIF(mint(106+jt).EQ.3) THEN

            pt=sqrt(vint(282+jt))

            pt=pt*0.8d0**mint(57)

            IF(ntry.GT.10) pt=pt*0.8d0**(ntry-10)

          ELSEIF(iabs(mint(14+jt)).LE.8.OR.mint(14+jt).EQ.21) THEN

            IF(mstp(93).LE.0) THEN

              pt=0d0

            ELSEIF(mstp(93).EQ.1) THEN

              pt=parp(99)*sqrt(-log(pyr(0)))

            ELSEIF(mstp(93).EQ.2) THEN

              rpt1=pyr(0)

              rpt2=pyr(0)

              pt=-parp(99)*log(rpt1*rpt2)

            ELSEIF(mstp(93).EQ.3) THEN

              ha=parp(99)**2

              hb=parp(100)**2

              pt=sqrt(max(0d0,ha*(ha+hb)/(ha+hb-pyr(0)*hb)-ha))

            ELSE

              ha=parp(99)**2

              hb=parp(100)**2

              IF(mstp(93).EQ.5) hb=min(vint(48),parp(100)**2)

              pt=sqrt(max(0d0,ha*((ha+hb)/ha)**pyr(0)-ha))

            ENDIF

            IF(pt.GT.parp(100)) goto 120

          ELSE

            pt=0d0

          ENDIF

          vint(156+jt)=pt

          phi=paru(2)*pyr(0)

          p(i,1)=pt*cos(phi)

          p(i,2)=pt*sin(phi)

          pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2

        ENDIF

  130 CONTINUE

      IF(mint(47).EQ.1) RETURN


C...Kinematics construction for initial partons.

      i1=mint(83)+3

      i2=mint(83)+4

      IF(isub.EQ.95) THEN

        shs=0d0

        shr=0d0

      ELSE

        shs=vint(141)*vint(142)*vint(2)+(p(i1,1)+p(i2,1))**2+

     &  (p(i1,2)+p(i2,2))**2

        shr=sqrt(max(0d0,shs))

        IF((shs-pms(1)-pms(2))**2-4d0*pms(1)*pms(2).LE.0d0) goto 100

        p(i1,4)=0.5d0*(shr+(pms(1)-pms(2))/shr)

        p(i1,3)=sqrt(max(0d0,p(i1,4)**2-pms(1)))

        p(i2,4)=shr-p(i1,4)

        p(i2,3)=-p(i1,3)


C...Transform partons to overall CM-frame.

        robo(3)=(p(i1,1)+p(i2,1))/shr

        robo(4)=(p(i1,2)+p(i2,2))/shr

        CALL pyrobo(i1,i2,0d0,0d0,-robo(3),-robo(4),0d0)

        robo(2)=pyangl(p(i1,1),p(i1,2))

        CALL pyrobo(i1,i2,0d0,-robo(2),0d0,0d0,0d0)

        robo(1)=pyangl(p(i1,3),p(i1,1))

        CALL pyrobo(i1,i2,-robo(1),0d0,0d0,0d0,0d0)

        CALL pyrobo(i1,mint(52),robo(1),robo(2),robo(3),robo(4),0d0)

        robo(5)=max(-0.999999d0,min(0.999999d0,(vint(141)-vint(142))/

     &  (vint(141)+vint(142))))

        CALL pyrobo(i1,mint(52),0d0,0d0,0d0,0d0,robo(5))

      ENDIF


C...Optionally fix up x and Q2 definitions for leptoproduction.

      idisxq=0

      IF((mint(43).EQ.2.OR.mint(43).EQ.3).AND.((isub.EQ.10.AND.

     &mstp(23).GE.1).OR.(isub.EQ.83.AND.mstp(23).GE.2))) idisxq=1

      IF(idisxq.EQ.1) THEN


C...Find where incoming and outgoing leptons/partons are sitting.

        lesd=1

        IF(mint(42).EQ.1) lesd=2

        lpin=mint(83)+3-lesd

        lein=mint(84)+lesd

        lqin=mint(84)+3-lesd

        leout=mint(84)+2+lesd

        lqout=mint(84)+5-lesd

        IF(k(lein,3).GT.lein) lein=k(lein,3)

        IF(k(lqin,3).GT.lqin) lqin=k(lqin,3)

        lscms=0

        DO 140 i=mint(84)+5,n

          IF(k(i,2).EQ.94) THEN

            lscms=i

            leout=i+lesd

            lqout=i+3-lesd

          ENDIF

  140   CONTINUE

        lqbg=ipu1

        IF(lesd.EQ.1) lqbg=ipu2


C...Calculate actual and wanted momentum transfer.

        xnom=vint(43-lesd)

        q2nom=-vint(45)

        hpk=2d0*(p(lpin,4)*p(lein,4)-p(lpin,1)*p(lein,1)-

     &  p(lpin,2)*p(lein,2)-p(lpin,3)*p(lein,3))*

     &  (p(mint(83)+lesd,4)*vint(40+lesd)/p(lein,4))

        hpt2=max(0d0,q2nom*(1d0-q2nom/(xnom*hpk)))

        fac=sqrt(hpt2/(p(leout,1)**2+p(leout,2)**2))

        p(n+1,1)=fac*p(leout,1)

        p(n+1,2)=fac*p(leout,2)

        p(n+1,3)=0.25d0*((hpk-q2nom/xnom)/p(lpin,4)-

     &  q2nom/(p(mint(83)+lesd,4)*vint(40+lesd)))*(-1)**(lesd+1)

        p(n+1,4)=sqrt(p(leout,5)**2+p(n+1,1)**2+p(n+1,2)**2+

     &  p(n+1,3)**2)

        DO 150 j=1,4

          qold(j)=p(lein,j)-p(leout,j)

          qnew(j)=p(lein,j)-p(n+1,j)

  150   CONTINUE


C...Boost outgoing electron and daughters.

        IF(lscms.EQ.0) THEN

          DO 160 j=1,4

            p(leout,j)=p(n+1,j)

  160     CONTINUE

        ELSE

          DO 170 j=1,3

            p(n+2,j)=(p(n+1,j)-p(leout,j))/(p(n+1,4)+p(leout,4))

  170     CONTINUE

          pinv=2d0/(1d0+p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2)

          DO 180 j=1,3

            dbe(j)=pinv*p(n+2,j)

  180     CONTINUE

          DO 200 i=lscms+1,n

            iorig=i

  190       iorig=k(iorig,3)

            IF(iorig.GT.leout) goto 190

            IF(i.EQ.leout.OR.iorig.EQ.leout)

     &      CALL pyrobo(i,i,0d0,0d0,dbe(1),dbe(2),dbe(3))

  200     CONTINUE

        ENDIF


C...Copy shower initiator and all outgoing partons.

        ncop=n+1

        k(ncop,3)=lqbg

        DO 210 j=1,5

          p(ncop,j)=p(lqbg,j)

  210   CONTINUE

        DO 240 i=mint(84)+1,n

          icop=0

          IF(k(i,1).GT.10) goto 240

          IF(i.EQ.lqbg.OR.i.EQ.lqout) THEN

            icop=i

          ELSE

            iorig=i

  220       iorig=k(iorig,3)

            IF(iorig.EQ.lqbg.OR.iorig.EQ.lqout) THEN

              icop=iorig

            ELSEIF(iorig.GT.mint(84).AND.iorig.LE.n) THEN

              goto 220

            ENDIF

          ENDIF

          IF(icop.NE.0) THEN

            ncop=ncop+1

            k(ncop,3)=i

            DO 230 j=1,5

              p(ncop,j)=p(i,j)

  230       CONTINUE

          ENDIF

  240   CONTINUE


C...Calculate relative rescaling factors.

        slc=3-2*lesd

        plcsum=0d0

        DO 250 i=n+2,ncop

          plcsum=plcsum+(p(i,4)+slc*p(i,3))

  250   CONTINUE

        DO 260 i=n+2,ncop

          v(i,1)=(p(i,4)+slc*p(i,3))/plcsum

  260   CONTINUE


C...Transfer extra three-momentum of current.

        DO 280 i=n+2,ncop

          DO 270 j=1,3

            p(i,j)=p(i,j)+v(i,1)*(qnew(j)-qold(j))

  270     CONTINUE

          p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

  280   CONTINUE


C...Iterate change of initiator momentum to get energy right.

        iter=0

  290   iter=iter+1

        peex=-p(n+1,4)-qnew(4)

        pemv=-p(n+1,3)/p(n+1,4)

        DO 300 i=n+2,ncop

          peex=peex+p(i,4)

          pemv=pemv+v(i,1)*p(i,3)/p(i,4)

  300   CONTINUE

        IF(abs(pemv).LT.1d-10) THEN

          mint(51)=1

          mint(57)=mint(57)+1

          RETURN

        ENDIF

        pzch=-peex/pemv

        p(n+1,3)=p(n+1,3)+pzch

        p(n+1,4)=sqrt(p(n+1,5)**2+p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)

        DO 310 i=n+2,ncop

          p(i,3)=p(i,3)+v(i,1)*pzch

          p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

  310   CONTINUE

        IF(iter.LT.10.AND.abs(peex).GT.1d-6*p(n+1,4)) goto 290


C...Modify momenta in event record.

        hbe=2d0*(p(n+1,4)+p(lqbg,4))*(p(n+1,3)-p(lqbg,3))/

     &  ((p(n+1,4)+p(lqbg,4))**2+(p(n+1,3)-p(lqbg,3))**2)

        IF(abs(hbe).GT.0.999999d0) THEN

          mint(51)=1

          mint(57)=mint(57)+1

          RETURN

        ENDIF

        i=mint(83)+5-lesd

        CALL pyrobo(i,i,0d0,0d0,0d0,0d0,hbe)

        DO 330 i=n+1,ncop

          icop=k(i,3)

          DO 320 j=1,4

            p(icop,j)=p(i,j)

  320     CONTINUE

  330   CONTINUE

      ENDIF


C...Check minimum invariant mass of remnant system(s).

      psys(0,4)=p(i1,4)+p(i2,4)+0.5d0*vint(1)*(vint(151)+vint(152))

      psys(0,3)=p(i1,3)+p(i2,3)+0.5d0*vint(1)*(vint(151)-vint(152))

      pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)

      pmin(0)=sqrt(pms(0))

      DO 340 jt=1,2

        psys(jt,4)=0.5d0*vint(1)*vint(142+jt)

        psys(jt,3)=psys(jt,4)*(-1)**(jt-1)

        pmin(jt)=0d0

        IF(mint(44+jt).EQ.1) goto 340

        mint(105)=mint(102+jt)

        mint(109)=mint(106+jt)

        CALL pyspli(mint(10+jt),mint(12+jt),kflch(jt),kflsp(jt))

        IF(kflch(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflch(jt))

        IF(kflsp(jt).NE.0) pmin(jt)=pmin(jt)+pymass(kflsp(jt))

        IF(kflch(jt)*kflsp(jt).NE.0) pmin(jt)=pmin(jt)+0.5d0*parp(111)

        pmin(jt)=sqrt(pmin(jt)**2+p(mint(83)+jt+2,1)**2+

     &  p(mint(83)+jt+2,2)**2)

  340 CONTINUE

      IF(pmin(0)+pmin(1)+pmin(2).GT.vint(1).OR.(mint(45).GE.2.AND.

     &pmin(1).GT.psys(1,4)).OR.(mint(46).GE.2.AND.pmin(2).GT.

     &psys(2,4))) THEN

        mint(51)=1

        mint(57)=mint(57)+1

        RETURN

      ENDIF


C...Loop over two remnants; skip if none there.

      i=ns

      DO 410 jt=1,2

        isn(jt)=0

        IF(mint(44+jt).EQ.1) goto 410

        IF(jt.EQ.1) ipu=ipu1

        IF(jt.EQ.2) ipu=ipu2


C...Store first remnant parton.

        i=i+1

        is(jt)=i

        isn(jt)=1

        DO 350 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  350   CONTINUE

        k(i,1)=1

        k(i,2)=kflsp(jt)

        k(i,3)=mint(83)+jt

        p(i,5)=pymass(k(i,2))


C...First parton colour connections and kinematics.

        kcol=kchg(pycomp(kflsp(jt)),2)

        IF(kcol.EQ.2) THEN

          k(i,1)=3

          k(i,4)=mstu(5)*ipu+ipu

          k(i,5)=mstu(5)*ipu+ipu

          k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i

          k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i

        ELSEIF(kcol.NE.0) THEN

          k(i,1)=3

          kfls=(3-kcol*isign(1,kflsp(jt)))/2

          k(i,kfls+3)=ipu

          k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i

        ENDIF

        IF(kflch(jt).EQ.0) THEN

          p(i,1)=-p(mint(83)+jt+2,1)

          p(i,2)=-p(mint(83)+jt+2,2)

          pms(jt)=p(i,5)**2+p(i,1)**2+p(i,2)**2

          psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)

          p(i,3)=psys(jt,3)

          p(i,4)=psys(jt,4)


C...When extra remnant parton or hadron: store extra remnant.

        ELSE

          i=i+1

          isn(jt)=2

          DO 360 j=1,5

            k(i,j)=0

            p(i,j)=0d0

            v(i,j)=0d0

  360     CONTINUE

          k(i,1)=1

          k(i,2)=kflch(jt)

          k(i,3)=mint(83)+jt

          p(i,5)=pymass(k(i,2))


C...Find parton colour connections of extra remnant.

          kcol=kchg(pycomp(kflch(jt)),2)

          IF(kcol.EQ.2) THEN

            k(i,1)=3

            k(i,4)=mstu(5)*ipu+ipu

            k(i,5)=mstu(5)*ipu+ipu

            k(ipu,4)=mod(k(ipu,4),mstu(5))+mstu(5)*i

            k(ipu,5)=mod(k(ipu,5),mstu(5))+mstu(5)*i

          ELSEIF(kcol.NE.0) THEN

            k(i,1)=3

            kfls=(3-kcol*isign(1,kflch(jt)))/2

            k(i,kfls+3)=ipu

            k(ipu,6-kfls)=mod(k(ipu,6-kfls),mstu(5))+mstu(5)*i

          ENDIF


C...Relative transverse momentum when two remnants.

          loop=0

  370     loop=loop+1

          CALL pyptdi(1,p(i-1,1),p(i-1,2))

          IF(iabs(mint(10+jt)).LT.20) THEN

            p(i-1,1)=0d0

            p(i-1,2)=0d0

          ENDIF

          pms(jt+2)=p(i-1,5)**2+p(i-1,1)**2+p(i-1,2)**2

          p(i,1)=-p(mint(83)+jt+2,1)-p(i-1,1)

          p(i,2)=-p(mint(83)+jt+2,2)-p(i-1,2)

          pms(jt+4)=p(i,5)**2+p(i,1)**2+p(i,2)**2


C...Meson or baryon; photon as meson. For splitup below.

          imb=1

          IF(mod(mint(10+jt)/1000,10).NE.0) imb=2


C***Relative distribution for electron into two electrons. Temporary!

          IF(iabs(mint(10+jt)).LT.20.AND.mint(14+jt).EQ.-mint(10+jt))

     &    THEN

            chi(jt)=pyr(0)


C...Relative distribution of electron energy into electron plus parton.

          ELSEIF(iabs(mint(10+jt)).LT.20) THEN

            xhrd=vint(140+jt)

            xe=vint(154+jt)

            chi(jt)=(xe-xhrd)/(1d0-xhrd)


C...Relative distribution of energy for particle into two jets.

          ELSEIF(iabs(kflch(jt)).LE.10.OR.kflch(jt).EQ.21) THEN

            chik=parp(92+2*imb)

            IF(mstp(92).LE.1) THEN

              IF(imb.EQ.1) chi(jt)=pyr(0)

              IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))

            ELSEIF(mstp(92).EQ.2) THEN

              chi(jt)=1d0-pyr(0)**(1d0/(1d0+chik))

            ELSEIF(mstp(92).EQ.3) THEN

              cut=2d0*0.3d0/vint(1)

  380         chi(jt)=pyr(0)**2

              IF((chi(jt)**2/(chi(jt)**2+cut**2))**0.25d0*

     &        (1d0-chi(jt))**chik.LT.pyr(0)) goto 380

            ELSEIF(mstp(92).EQ.4) THEN

              cut=2d0*0.3d0/vint(1)

              cutr=(1d0+sqrt(1d0+cut**2))/cut

  390         chir=cut*cutr**pyr(0)

              chi(jt)=(chir**2-cut**2)/(2d0*chir)

              IF((1d0-chi(jt))**chik.LT.pyr(0)) goto 390

            ELSE

              cut=2d0*0.3d0/vint(1)

              cuta=cut**(1d0-parp(98))

              cutb=(1d0+cut)**(1d0-parp(98))

  400         chi(jt)=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))

              IF(((chi(jt)+cut)**2/(2d0*(chi(jt)**2+cut**2)))**

     &        (0.5d0*parp(98))*(1d0-chi(jt))**chik.LT.pyr(0)) goto 400

            ENDIF


C...Relative distribution of energy for particle into jet plus particle.

          ELSE

            IF(mstp(94).LE.1) THEN

              IF(imb.EQ.1) chi(jt)=pyr(0)

              IF(imb.EQ.2) chi(jt)=1d0-sqrt(pyr(0))

              IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)

            ELSEIF(mstp(94).EQ.2) THEN

              chi(jt)=1d0-pyr(0)**(1d0/(1d0+parp(93+2*imb)))

              IF(mod(kflch(jt)/1000,10).NE.0) chi(jt)=1d0-chi(jt)

            ELSEIF(mstp(94).EQ.3) THEN

              CALL pyzdis(1,0,pms(jt+4),zz)

              chi(jt)=zz

            ELSE

              CALL pyzdis(1000,0,pms(jt+4),zz)

              chi(jt)=zz

            ENDIF

          ENDIF


C...Construct total transverse mass; reject if too large.

          pms(jt)=pms(jt+4)/chi(jt)+pms(jt+2)/(1d0-chi(jt))

          IF(pms(jt).GT.psys(jt,4)**2) THEN

            IF(loop.LT.10) THEN

              goto 370

            ELSE

              mint(51)=1

              mint(57)=mint(57)+1

              RETURN

            ENDIF

          ENDIF

          psys(jt,3)=sqrt(max(0d0,psys(jt,4)**2-pms(jt)))*(-1)**(jt-1)

          vint(158+jt)=chi(jt)


C...Subdivide longitudinal momentum according to value selected above.

          pw1=chi(jt)*(psys(jt,4)+abs(psys(jt,3)))

          p(is(jt)+1,4)=0.5d0*(pw1+pms(jt+4)/pw1)

          p(is(jt)+1,3)=0.5d0*(pw1-pms(jt+4)/pw1)*(-1)**(jt-1)

          p(is(jt),4)=psys(jt,4)-p(is(jt)+1,4)

          p(is(jt),3)=psys(jt,3)-p(is(jt)+1,3)

        ENDIF

  410 CONTINUE

      n=i


C...Check if longitudinal boosts needed - if so pick two systems.

      pdev=abs(psys(0,4)+psys(1,4)+psys(2,4)-vint(1))+

     &abs(psys(0,3)+psys(1,3)+psys(2,3))

      IF(pdev.LE.1d-6*vint(1)) RETURN

      IF(isn(1).EQ.0) THEN

        ir=0

        il=2

      ELSEIF(isn(2).EQ.0) THEN

        ir=1

        il=0

      ELSEIF(vint(143).GT.0.2d0.AND.vint(144).GT.0.2d0) THEN

        ir=1

        il=2

      ELSEIF(vint(143).GT.0.2d0) THEN

        ir=1

        il=0

      ELSEIF(vint(144).GT.0.2d0) THEN

        ir=0

        il=2

      ELSEIF(pms(1)/psys(1,4)**2.GT.pms(2)/psys(2,4)**2) THEN

        ir=1

        il=0

      ELSE

        ir=0

        il=2

      ENDIF

      ig=3-ir-il


C...E+-pL wanted for system to be modified.

      IF((ig.EQ.1.AND.isn(1).EQ.0).OR.(ig.EQ.2.AND.isn(2).EQ.0)) THEN

        ppb=vint(1)

        pnb=vint(1)

      ELSE

        ppb=vint(1)-(psys(ig,4)+psys(ig,3))

        pnb=vint(1)-(psys(ig,4)-psys(ig,3))

      ENDIF


C...To keep x and Q2 in leptoproduction: do not count scattered lepton.

      IF(idisxq.EQ.1.AND.ig.NE.0) THEN

        pmtb=ppb*pnb

        pmtr=pms(ir)

        pmtl=pms(il)

        sqlam=sqrt(max(0d0,(pmtb-pmtr-pmtl)**2-4d0*pmtr*pmtl))

        sqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))

        rkr=(pmtb+pmtr-pmtl+sqlam*sqsgn)/(2d0*(psys(ir,4)+psys(ir,3))

     &  *pnb)

        rkl=(pmtb+pmtl-pmtr+sqlam*sqsgn)/(2d0*(psys(il,4)-psys(il,3))

     &  *ppb)

        ber=(rkr**2-1d0)/(rkr**2+1d0)

        bel=-(rkl**2-1d0)/(rkl**2+1d0)

        ppb=ppb-(psys(0,4)+psys(0,3))

        pnb=pnb-(psys(0,4)-psys(0,3))

        DO 420 j=1,4

          psys(0,j)=0d0

  420   CONTINUE

        DO 450 i=mint(84)+1,ns

          IF(k(i,1).GT.10) goto 450

          incl=0

          iorig=i

  430     IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1

          iorig=k(iorig,3)

          IF(iorig.GT.lpin) goto 430

          IF(incl.EQ.0) goto 450

          DO 440 j=1,4

            psys(0,j)=psys(0,j)+p(i,j)

  440     CONTINUE

  450   CONTINUE

        pms(0)=max(0d0,psys(0,4)**2-psys(0,3)**2)

        ppb=ppb+(psys(0,4)+psys(0,3))

        pnb=pnb+(psys(0,4)-psys(0,3))

      ENDIF


C...Construct longitudinal boosts.

      dpmtb=ppb*pnb

      dpmtr=pms(ir)

      dpmtl=pms(il)

      dsqlam=sqrt(max(0d0,(dpmtb-dpmtr-dpmtl)**2-4d0*dpmtr*dpmtl))

      IF(dsqlam.LE.1d-6*dpmtb) THEN

        mint(51)=1

        mint(57)=mint(57)+1

        RETURN

      ENDIF

      dsqsgn=sign(1d0,psys(ir,3)*psys(il,4)-psys(il,3)*psys(ir,4))

      drkr=(dpmtb+dpmtr-dpmtl+dsqlam*dsqsgn)/

     &(2d0*(psys(ir,4)+psys(ir,3))*pnb)

      drkl=(dpmtb+dpmtl-dpmtr+dsqlam*dsqsgn)/

     &(2d0*(psys(il,4)-psys(il,3))*ppb)

      dber=(drkr**2-1d0)/(drkr**2+1d0)

      dbel=-(drkl**2-1d0)/(drkl**2+1d0)


C...Perform longitudinal boosts.

      IF(ir.EQ.1.AND.isn(1).EQ.1.AND.dber.LE.-0.99999999d0) THEN

        p(is(1),3)=0d0

        p(is(1),4)=sqrt(p(is(1),5)**2+p(is(1),1)**2+p(is(1),2)**2)

      ELSEIF(ir.EQ.1) THEN

        CALL pyrobo(is(1),is(1)+isn(1)-1,0d0,0d0,0d0,0d0,dber)

      ELSEIF(idisxq.EQ.1) THEN

        DO 470 i=i1,ns

          incl=0

          iorig=i

  460     IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1

          iorig=k(iorig,3)

          IF(iorig.GT.lpin) goto 460

          IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dber)

  470   CONTINUE

      ELSE

        CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dber)

      ENDIF

      IF(il.EQ.2.AND.isn(2).EQ.1.AND.dbel.GE.0.99999999d0) THEN

        p(is(2),3)=0d0

        p(is(2),4)=sqrt(p(is(2),5)**2+p(is(2),1)**2+p(is(2),2)**2)

      ELSEIF(il.EQ.2) THEN

        CALL pyrobo(is(2),is(2)+isn(2)-1,0d0,0d0,0d0,0d0,dbel)

      ELSEIF(idisxq.EQ.1) THEN

        DO 490 i=i1,ns

          incl=0

          iorig=i

  480     IF(iorig.EQ.lqout.OR.iorig.EQ.lpin+2) incl=1

          iorig=k(iorig,3)

          IF(iorig.GT.lpin) goto 480

          IF(incl.EQ.1) CALL pyrobo(i,i,0d0,0d0,0d0,0d0,dbel)

  490   CONTINUE

      ELSE

        CALL pyrobo(i1,ns,0d0,0d0,0d0,0d0,dbel)

      ENDIF


C...Final check that energy-momentum conservation worked.

      pesum=0d0

      pzsum=0d0

      DO 500 i=mint(84)+1,n

        IF(k(i,1).GT.10) goto 500

        pesum=pesum+p(i,4)

        pzsum=pzsum+p(i,3)

  500 CONTINUE

      pdev=abs(pesum-vint(1))+abs(pzsum)

      IF(pdev.GT.1d-4*vint(1)) THEN

        mint(51)=1

        mint(57)=mint(57)+1

        RETURN

      ENDIF


C...Calculate rotation and boost from overall CM frame to

C...hadronic CM frame in leptoproduction.

      mint(91)=0

      IF(mint(82).EQ.1.AND.(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN

        mint(91)=1

        lesd=1

        IF(mint(42).EQ.1) lesd=2

        lpin=mint(83)+3-lesd


C...Sum upp momenta of everything not lepton or photon to define boost.

        DO 510 j=1,4

          psum(j)=0d0

  510   CONTINUE

        DO 530 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 530

          IF(iabs(k(i,2)).GE.11.AND.iabs(k(i,2)).LE.20) goto 530

          IF(k(i,2).EQ.22) goto 530

          DO 520 j=1,4

            psum(j)=psum(j)+p(i,j)

  520     CONTINUE

  530   CONTINUE

        vint(223)=-psum(1)/psum(4)

        vint(224)=-psum(2)/psum(4)

        vint(225)=-psum(3)/psum(4)


C...Boost incoming hadron to hadronic CM frame to determine rotations.

        k(n+1,1)=1

        DO 540 j=1,5

          p(n+1,j)=p(lpin,j)

          v(n+1,j)=v(lpin,j)

  540   CONTINUE

        CALL pyrobo(n+1,n+1,0d0,0d0,vint(223),vint(224),vint(225))

        vint(222)=-pyangl(p(n+1,1),p(n+1,2))

        CALL pyrobo(n+1,n+1,0d0,vint(222),0d0,0d0,0d0)

        IF(lesd.EQ.2) THEN

          vint(221)=-pyangl(p(n+1,3),p(n+1,1))

        ELSE

          vint(221)=pyangl(-p(n+1,3),p(n+1,1))

        ENDIF

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYDIFF

C...Handles diffractive and elastic scattering.


      SUBROUTINE pydiff


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pyjets/,/pydat1/,/pypars/,/pyint1/


C...Reset K, P and V vectors. Store incoming particles.

      DO 110 jt=1,mstp(126)+10

        i=mint(83)+jt

        DO 100 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  100   CONTINUE

  110 CONTINUE

      n=mint(84)

      mint(3)=0

      mint(21)=0

      mint(22)=0

      mint(23)=0

      mint(24)=0

      mint(4)=4

      DO 130 jt=1,2

        i=mint(83)+jt

        k(i,1)=21

        k(i,2)=mint(10+jt)

        DO 120 j=1,5

          p(i,j)=vint(285+5*jt+j)

  120   CONTINUE

  130 CONTINUE

      mint(6)=2


C...Subprocess; kinematics.

      sqlam=(vint(2)-vint(63)-vint(64))**2-4d0*vint(63)*vint(64)

      pz=sqrt(sqlam)/(2d0*vint(1))

      DO 200 jt=1,2

        i=mint(83)+jt

        pe=(vint(2)+vint(62+jt)-vint(65-jt))/(2d0*vint(1))

        kfh=mint(102+jt)


C...Elastically scattered particle.

        IF(mint(16+jt).LE.0) THEN

          n=n+1

          k(n,1)=1

          k(n,2)=kfh

          k(n,3)=i+2

          p(n,3)=pz*(-1)**(jt+1)

          p(n,4)=pe

          p(n,5)=sqrt(vint(62+jt))


C...Decay rho from elastic scattering of gamma with sin**2(theta)

C...distribution of decay products (in rho rest frame).

          IF(kfh.EQ.113.AND.mint(10+jt).EQ.22.AND.mstp(102).EQ.1) THEN

            nsav=n

            dbetaz=p(n,3)/sqrt(p(n,3)**2+p(n,5)**2)

            p(n,3)=0d0

            p(n,4)=p(n,5)

            CALL pydecy(nsav)

            IF(n.EQ.nsav+2.AND.iabs(k(nsav+1,2)).EQ.211) THEN

              phi=pyangl(p(nsav+1,1),p(nsav+1,2))

              CALL pyrobo(nsav+1,nsav+2,0d0,-phi,0d0,0d0,0d0)

              the=pyangl(p(nsav+1,3),p(nsav+1,1))

              CALL pyrobo(nsav+1,nsav+2,-the,0d0,0d0,0d0,0d0)

  140         cthe=2d0*pyr(0)-1d0

              IF(1d0-cthe**2.LT.pyr(0)) goto 140

              CALL pyrobo(nsav+1,nsav+2,acos(cthe),phi,0d0,0d0,0d0)

            ENDIF

            CALL pyrobo(nsav,nsav+2,0d0,0d0,0d0,0d0,dbetaz)

          ENDIF


C...Diffracted particle: low-mass system to two particles.

        ELSEIF(vint(62+jt).LT.(vint(66+jt)+parp(103))**2) THEN

          n=n+2

          k(n-1,1)=1

          k(n,1)=1

          k(n-1,3)=i+2

          k(n,3)=i+2

          pmmas=sqrt(vint(62+jt))

          ntry=0

  150     ntry=ntry+1

          IF(ntry.LT.20) THEN

            mint(105)=mint(102+jt)

            mint(109)=mint(106+jt)

            CALL pyspli(kfh,21,kfl1,kfl2)

            CALL pykfdi(kfl1,0,kfl3,kf1)

            IF(kf1.EQ.0) goto 150

            CALL pykfdi(kfl2,-kfl3,kfldum,kf2)

            IF(kf2.EQ.0) goto 150

          ELSE

            kf1=kfh

            kf2=111

          ENDIF

          pm1=pymass(kf1)

          pm2=pymass(kf2)

          IF(pm1+pm2+parj(64).GT.pmmas) goto 150

          k(n-1,2)=kf1

          k(n,2)=kf2

          p(n-1,5)=pm1

          p(n,5)=pm2

          pzp=sqrt(max(0d0,(pmmas**2-pm1**2-pm2**2)**2-

     &    4d0*pm1**2*pm2**2))/(2d0*pmmas)

          p(n-1,3)=pzp

          p(n,3)=-pzp

          p(n-1,4)=sqrt(pm1**2+pzp**2)

          p(n,4)=sqrt(pm2**2+pzp**2)

          CALL pyrobo(n-1,n,acos(2d0*pyr(0)-1d0),paru(2)*pyr(0),

     &    0d0,0d0,0d0)

          dbetaz=pz*(-1)**(jt+1)/sqrt(pz**2+pmmas**2)

          CALL pyrobo(n-1,n,0d0,0d0,0d0,0d0,dbetaz)


C...Diffracted particle: valence quark kicked out.

        ELSEIF(mstp(101).EQ.1.OR.(mstp(101).EQ.3.AND.pyr(0).LT.

     &    parp(101))) THEN

          n=n+2

          k(n-1,1)=2

          k(n,1)=1

          k(n-1,3)=i+2

          k(n,3)=i+2

          mint(105)=mint(102+jt)

          mint(109)=mint(106+jt)

          CALL pyspli(kfh,21,k(n,2),k(n-1,2))

          p(n-1,5)=pymass(k(n-1,2))

          p(n,5)=pymass(k(n,2))

          sqlam=(vint(62+jt)-p(n-1,5)**2-p(n,5)**2)**2-

     &    4d0*p(n-1,5)**2*p(n,5)**2

          p(n-1,3)=(pe*sqrt(sqlam)+pz*(vint(62+jt)+p(n-1,5)**2-

     &    p(n,5)**2))/(2d0*vint(62+jt))*(-1)**(jt+1)

          p(n-1,4)=sqrt(p(n-1,3)**2+p(n-1,5)**2)

          p(n,3)=pz*(-1)**(jt+1)-p(n-1,3)

          p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)


C...Diffracted particle: gluon kicked out.

        ELSE

          n=n+3

          k(n-2,1)=2

          k(n-1,1)=2

          k(n,1)=1

          k(n-2,3)=i+2

          k(n-1,3)=i+2

          k(n,3)=i+2

          mint(105)=mint(102+jt)

          mint(109)=mint(106+jt)

          CALL pyspli(kfh,21,k(n,2),k(n-2,2))

          k(n-1,2)=21

          p(n-2,5)=pymass(k(n-2,2))

          p(n-1,5)=0d0

          p(n,5)=pymass(k(n,2))

C...Energy distribution for particle into two jets.

  160     imb=1

          IF(mod(kfh/1000,10).NE.0) imb=2

          chik=parp(92+2*imb)

          IF(mstp(92).LE.1) THEN

            IF(imb.EQ.1) chi=pyr(0)

            IF(imb.EQ.2) chi=1d0-sqrt(pyr(0))

          ELSEIF(mstp(92).EQ.2) THEN

            chi=1d0-pyr(0)**(1d0/(1d0+chik))

          ELSEIF(mstp(92).EQ.3) THEN

            cut=2d0*0.3d0/vint(1)

  170       chi=pyr(0)**2

            IF((chi**2/(chi**2+cut**2))**0.25d0*(1d0-chi)**chik.LT.

     &      pyr(0)) goto 170

          ELSEIF(mstp(92).EQ.4) THEN

            cut=2d0*0.3d0/vint(1)

            cutr=(1d0+sqrt(1d0+cut**2))/cut

  180       chir=cut*cutr**pyr(0)

            chi=(chir**2-cut**2)/(2d0*chir)

            IF((1d0-chi)**chik.LT.pyr(0)) goto 180

          ELSE

            cut=2d0*0.3d0/vint(1)

            cuta=cut**(1d0-parp(98))

            cutb=(1d0+cut)**(1d0-parp(98))

  190       chi=(cuta+pyr(0)*(cutb-cuta))**(1d0/(1d0-parp(98)))

            IF(((chi+cut)**2/(2d0*(chi**2+cut**2)))**

     &      (0.5d0*parp(98))*(1d0-chi)**chik.LT.pyr(0)) goto 190

          ENDIF

          IF(chi.LT.p(n,5)**2/vint(62+jt).OR.chi.GT.1d0-p(n-2,5)**2/

     &    vint(62+jt)) goto 160

          sqm=p(n-2,5)**2/(1d0-chi)+p(n,5)**2/chi

          IF((sqrt(sqm)+parj(32))**2.GE.vint(62+jt)) goto 160

          pzi=(pe*(vint(62+jt)-sqm)+pz*(vint(62+jt)+sqm))/

     &    (2d0*vint(62+jt))

          pei=sqrt(pzi**2+sqm)

          pqqp=(1d0-chi)*(pei+pzi)

          p(n-2,3)=0.5d0*(pqqp-p(n-2,5)**2/pqqp)*(-1)**(jt+1)

          p(n-2,4)=sqrt(p(n-2,3)**2+p(n-2,5)**2)

          p(n-1,4)=0.5d0*(vint(62+jt)-sqm)/(pei+pzi)

          p(n-1,3)=p(n-1,4)*(-1)**jt

          p(n,3)=pzi*(-1)**(jt+1)-p(n-2,3)

          p(n,4)=sqrt(p(n,3)**2+p(n,5)**2)

        ENDIF


C...Documentation lines.

        k(i+2,1)=21

        IF(mint(16+jt).EQ.0) k(i+2,2)=kfh

        IF(mint(16+jt).NE.0) k(i+2,2)=10*(kfh/10)

        k(i+2,3)=i

        p(i+2,3)=pz*(-1)**(jt+1)

        p(i+2,4)=pe

        p(i+2,5)=sqrt(vint(62+jt))

  200 CONTINUE


C...Rotate outgoing partons/particles using cos(theta).

      IF(vint(23).LT.0.9d0) THEN

        CALL pyrobo(mint(83)+3,n,acos(vint(23)),vint(24),0d0,0d0,0d0)

      ELSE

        CALL pyrobo(mint(83)+3,n,asin(vint(59)),vint(24),0d0,0d0,0d0)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYDOCU

C...Handles the documentation of the process in MSTI and PARI,

C...and also computes cross-sections based on accumulated statistics.


      SUBROUTINE pydocu


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      SAVE /pyjets/,/pydat1/,/pysubs/,/pypars/,/pyint1/,/pyint2/,

     &/pyint5/


C...Calculate Monte Carlo estimates of cross-sections.

      isub=mint(1)

      IF(mstp(111).NE.-1) ngen(isub,3)=ngen(isub,3)+1

      ngen(0,3)=ngen(0,3)+1

      xsec(0,3)=0d0

      DO 100 i=1,500

        IF(i.EQ.96.OR.i.EQ.97) THEN

          xsec(i,3)=0d0

        ELSEIF(msub(95).EQ.1.AND.(i.EQ.11.OR.i.EQ.12.OR.i.EQ.13.OR.

     &    i.EQ.28.OR.i.EQ.53.OR.i.EQ.68)) THEN

          xsec(i,3)=xsec(96,2)*ngen(i,3)/max(1d0,dble(ngen(96,1))*

     &    dble(ngen(96,2)))

        ELSEIF(msub(i).EQ.0.OR.ngen(i,1).EQ.0) THEN

          xsec(i,3)=0d0

        ELSEIF(ngen(i,2).EQ.0) THEN

          xsec(i,3)=xsec(i,2)*ngen(0,3)/(dble(ngen(i,1))*

     &    dble(ngen(0,2)))

        ELSE

          xsec(i,3)=xsec(i,2)*ngen(i,3)/(dble(ngen(i,1))*

     &    dble(ngen(i,2)))

        ENDIF

        xsec(0,3)=xsec(0,3)+xsec(i,3)

  100 CONTINUE


C...Rescale to known low-pT cross-section for standard QCD processes.

      IF(msub(95).EQ.1) THEN

        xsech=xsec(11,3)+xsec(12,3)+xsec(13,3)+xsec(28,3)+xsec(53,3)+

     &  xsec(68,3)+xsec(95,3)

        xsecw=xsec(97,2)/max(1d0,dble(ngen(97,1)))

        IF(xsech.GT.1d-10.AND.xsecw.GT.1d-10) THEN

          fac=xsecw/xsech

          xsec(11,3)=fac*xsec(11,3)

          xsec(12,3)=fac*xsec(12,3)

          xsec(13,3)=fac*xsec(13,3)

          xsec(28,3)=fac*xsec(28,3)

          xsec(53,3)=fac*xsec(53,3)

          xsec(68,3)=fac*xsec(68,3)

          xsec(95,3)=fac*xsec(95,3)

          xsec(0,3)=xsec(0,3)-xsech+xsecw

        ENDIF

      ENDIF


C...Save information for gamma-p and gamma-gamma.

      IF(mint(121).GT.1) THEN

        iga=mint(122)

        CALL pysave(2,iga)

        CALL pysave(5,0)

      ENDIF


C...Reset information on hard interaction.

      DO 110 j=1,200

        msti(j)=0

        pari(j)=0d0

  110 CONTINUE


C...Copy integer valued information from MINT into MSTI.

      DO 120 j=1,32

        msti(j)=mint(j)

  120 CONTINUE

      IF(mint(121).GT.1) msti(9)=mint(122)


C...Store cross-section variables in PARI.

      pari(1)=xsec(0,3)

      pari(2)=xsec(0,3)/mint(5)

      pari(9)=vint(99)

      pari(10)=vint(100)

      vint(98)=vint(98)+vint(100)

      IF(mstp(142).EQ.1) pari(2)=xsec(0,3)/vint(98)


C...Store kinematics variables in PARI.

      pari(11)=vint(1)

      pari(12)=vint(2)

      IF(isub.NE.95) THEN

        DO 130 j=13,26

          pari(j)=vint(30+j)

  130   CONTINUE

        pari(31)=vint(141)

        pari(32)=vint(142)

        pari(33)=vint(41)

        pari(34)=vint(42)

        pari(35)=pari(33)-pari(34)

        pari(36)=vint(21)

        pari(37)=vint(22)

        pari(38)=vint(26)

        pari(39)=vint(157)

        pari(40)=vint(158)

        pari(41)=vint(23)

        pari(42)=2d0*vint(47)/vint(1)

      ENDIF


C...Store information on scattered partons in PARI.

      IF(isub.NE.95.AND.mint(7)*mint(8).NE.0) THEN

        DO 140 is=7,8

          i=mint(is)

          pari(36+is)=p(i,3)/vint(1)

          pari(38+is)=p(i,4)/vint(1)

          pr=max(1d-20,p(i,5)**2+p(i,1)**2+p(i,2)**2)

          pari(40+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/

     &    sqrt(pr),1d20)),p(i,3))

          pr=max(1d-20,p(i,1)**2+p(i,2)**2)

          pari(42+is)=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/

     &    sqrt(pr),1d20)),p(i,3))

          pari(44+is)=p(i,3)/sqrt(1d-20+p(i,1)**2+p(i,2)**2+p(i,3)**2)

          pari(46+is)=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))

          pari(48+is)=pyangl(p(i,1),p(i,2))

  140   CONTINUE

      ENDIF


C...Store sum up transverse and longitudinal momenta.

      pari(65)=2d0*pari(17)

      IF(isub.LE.90.OR.isub.GE.95) THEN

        DO 150 i=mstp(126)+1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150

          pt=sqrt(p(i,1)**2+p(i,2)**2)

          pari(69)=pari(69)+pt

          IF(i.LE.mint(52)) pari(66)=pari(66)+pt

          IF(i.GT.mint(52).AND.i.LE.mint(53)) pari(68)=pari(68)+pt

  150   CONTINUE

        pari(67)=pari(68)

        pari(71)=vint(151)

        pari(72)=vint(152)

        pari(73)=vint(151)

        pari(74)=vint(152)

      ELSE

        pari(66)=pari(65)

        pari(69)=pari(65)

      ENDIF


C...Store various other pieces of information into PARI.

      pari(61)=vint(148)

      pari(75)=vint(155)

      pari(76)=vint(156)

      pari(77)=vint(159)

      pari(78)=vint(160)

      pari(81)=vint(138)


C...Set information for PYTABU.

      IF(iset(isub).EQ.1.OR.iset(isub).EQ.3) THEN

        mstu(161)=mint(21)

        mstu(162)=0

      ELSEIF(iset(isub).EQ.5) THEN

        mstu(161)=mint(23)

        mstu(162)=0

      ELSE

        mstu(161)=mint(21)

        mstu(162)=mint(22)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYFRAM

C...Performs transformations between different coordinate frames.


      SUBROUTINE pyfram(IFRAME)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pypars/,/pyint1/


C...Check that transformation can and should be done.

      IF(iframe.EQ.1.OR.iframe.EQ.2.OR.(iframe.EQ.3.AND.

     &mint(91).EQ.1)) THEN

        IF(iframe.EQ.mint(6)) RETURN

      ELSE

        WRITE(mstu(11),5000) iframe,mint(6)

        RETURN

      ENDIF


      IF(mint(6).EQ.1) THEN

C...Transform from fixed target or user specified frame to

C...overall CM frame.

        CALL pyrobo(0,0,0d0,0d0,-vint(8),-vint(9),-vint(10))

        CALL pyrobo(0,0,0d0,-vint(7),0d0,0d0,0d0)

        CALL pyrobo(0,0,-vint(6),0d0,0d0,0d0,0d0)

      ELSEIF(mint(6).EQ.3) THEN

C...Transform from hadronic CM frame in DIS to overall CM frame.

        CALL pyrobo(0,0,-vint(221),-vint(222),-vint(223),-vint(224),

     &  -vint(225))

      ENDIF


      IF(iframe.EQ.1) THEN

C...Transform from overall CM frame to fixed target or user specified

C...frame.

        CALL pyrobo(0,0,vint(6),vint(7),vint(8),vint(9),vint(10))

      ELSEIF(iframe.EQ.3) THEN

C...Transform from overall CM frame to hadronic CM frame in DIS.

        CALL pyrobo(0,0,0d0,0d0,vint(223),vint(224),vint(225))

        CALL pyrobo(0,0,0d0,vint(222),0d0,0d0,0d0)

        CALL pyrobo(0,0,vint(221),0d0,0d0,0d0,0d0)

      ENDIF


C...Set information about new frame.

      mint(6)=iframe

      msti(6)=iframe


 5000 FORMAT(1x,'Error: illegal values in subroutine PYFRAM.',1x,

     &'No transformation performed.'/1x,'IFRAME =',1x,i5,'; MINT(6) =',

     &1x,i5)


      RETURN

      END


C*********************************************************************


C...PYWIDT

C...Calculates full and partial widths of resonances.


      SUBROUTINE pywidt(KFLR,SH,WDTP,WDTE)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint4/mwid(500),wids(500,5)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,

     &/pyint4/,/pymssm/,/pyssmt/

C...Local arrays and saved variables.

      dimension wdtp(0:200),wdte(0:200,0:5),mofsv(3,2),widwsv(3,2),

     &wid2sv(3,2)

      SAVE mofsv,widwsv,wid2sv

      DATA mofsv/6*0/,widwsv/6*0d0/,wid2sv/6*0d0/


C...Compressed code and sign; mass.

      kfla=iabs(kflr)

      kfls=isign(1,kflr)

      kc=pycomp(kfla)

      shr=sqrt(sh)

      pmr=pmas(kc,1)


C...Reset width information.

      DO 110 i=0,200

        wdtp(i)=0d0

        DO 100 j=0,5

          wdte(i,j)=0d0

  100   CONTINUE

  110 CONTINUE


C...Not to be treated as a resonance: return.

      IF((mwid(kc).LE.0.OR.mwid(kc).GE.4).AND.kfla.NE.21.AND.

     &kfla.NE.22) THEN

        wdtp(0)=1d0

        wdte(0,0)=1d0

        mint(61)=0

        mint(62)=0

        mint(63)=0

        RETURN


C...Treatment as a resonance based on tabulated branching ratios.

      ELSEIF(mwid(kc).EQ.2.OR.(mwid(kc).EQ.3.AND.mint(63).EQ.0)) THEN

C...Loop over possible decay channels; skip irrelevant ones.

        DO 120 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 120


C...Read out decay products and nominal masses.

          kfd1=kfdp(idc,1)

          kfc1=pycomp(kfd1)

          IF(kchg(kfc1,3).EQ.1) kfd1=kfls*kfd1

          pm1=pmas(kfc1,1)

          kfd2=kfdp(idc,2)

          kfc2=pycomp(kfd2)

          IF(kchg(kfc2,3).EQ.1) kfd2=kfls*kfd2

          pm2=pmas(kfc2,1)

          kfd3=kfdp(idc,3)

          pm3=0d0

          IF(kfd3.NE.0) THEN

            kfc3=pycomp(kfd3)

            IF(kchg(kfc3,3).EQ.1) kfd3=kfls*kfd3

            pm3=pmas(kfc3,1)

          ENDIF


C...Naive partial width and alternative threshold factors.

          wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)

          IF(mdme(idc,2).GE.51.AND.mdme(idc,2).LE.53.AND.

     &    pm1+pm2+pm3.GE.shr) THEN

             wdtp(i)=0d0

          ELSEIF(mdme(idc,2).EQ.52.AND.kfd3.EQ.0) THEN

            wdtp(i)=wdtp(i)*sqrt(max(0d0,(sh-pm1**2-pm2**2)**2-

     &      4d0*pm1**2*pm2**2))/sh

          ELSEIF(mdme(idc,2).EQ.52) THEN

            pma=max(pm1,pm2,pm3)

            pmc=min(pm1,pm2,pm3)

            pmb=pm1+pm2+pm3-pma-pmc

            pmbc=pmb+pmc+0.5d0*(shr-pma-pmc-pmc)

            pman=pma**2/sh

            pmbn=pmb**2/sh

            pmcn=pmc**2/sh

            pmbcn=pmbc**2/sh

            wdtp(i)=wdtp(i)*sqrt(max(0d0,

     &      ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*

     &      ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*

     &      ((shr-pma)**2-(pmb+pmc)**2)*

     &      (1d0+0.25d0*(pma+pmb+pmc)/shr)/

     &      ((1d0-pmbcn)*pmbcn*sh)

          ELSEIF(mdme(idc,2).EQ.53.AND.kfd3.EQ.0) THEN

            wdtp(i)=wdtp(i)*sqrt(

     &      max(0d0,(sh-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2)/

     &      max(1d-4,(pmr**2-pm1**2-pm2**2)**2-4d0*pm1**2*pm2**2))

          ELSEIF(mdme(idc,2).EQ.53) THEN

            pma=max(pm1,pm2,pm3)

            pmc=min(pm1,pm2,pm3)

            pmb=pm1+pm2+pm3-pma-pmc

            pmbc=pmb+pmc+0.5d0*(shr-pma-pmb-pmc)

            pman=pma**2/sh

            pmbn=pmb**2/sh

            pmcn=pmc**2/sh

            pmbcn=pmbc**2/sh

            facact=sqrt(max(0d0,

     &      ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*

     &      ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*

     &      ((shr-pma)**2-(pmb+pmc)**2)*

     &      (1d0+0.25d0*(pma+pmb+pmc)/shr)/

     &      ((1d0-pmbcn)*pmbcn*sh)

            pmbc=pmb+pmc+0.5d0*(pmr-pma-pmb-pmc)

            pman=pma**2/pmr**2

            pmbn=pmb**2/pmr**2

            pmcn=pmc**2/pmr**2

            pmbcn=pmbc**2/pmr**2

            facnom=sqrt(max(0d0,

     &      ((1d0-pman-pmbcn)**2-4d0*pman*pmbcn)*

     &      ((pmbcn-pmbn-pmcn)**2-4d0*pmbn*pmcn)))*

     &      ((pmr-pma)**2-(pmb+pmc)**2)*

     &      (1d0+0.25d0*(pma+pmb+pmc)/pmr)/

     &      ((1d0-pmbcn)*pmbcn*pmr**2)

            wdtp(i)=wdtp(i)*facact/max(1d-6,facnom)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)


C...Calculate secondary width (at most two identical/opposite).

          IF(mdme(idc,1).GT.0) THEN

            IF(kfd2.EQ.kfd1) THEN

              IF(kchg(kfc1,3).EQ.0) THEN

                wid2=wids(kfc1,1)

              ELSEIF(kfd1.GT.0) THEN

                wid2=wids(kfc1,4)

              ELSE

                wid2=wids(kfc1,5)

              ENDIF

              IF(kfd3.GT.0) THEN

                wid2=wid2*wids(kfc3,2)

              ELSEIF(kfd3.LT.0) THEN

                wid2=wid2*wids(kfc3,3)

              ENDIF

            ELSEIF(kfd2.EQ.-kfd1) THEN

              wid2=wids(kfc1,1)

              IF(kfd3.GT.0) THEN

                wid2=wid2*wids(kfc3,2)

              ELSEIF(kfd3.LT.0) THEN

                wid2=wid2*wids(kfc3,3)

              ENDIF

            ELSEIF(kfd3.EQ.kfd1) THEN

              IF(kchg(kfc1,3).EQ.0) THEN

                wid2=wids(kfc1,1)

              ELSEIF(kfd1.GT.0) THEN

                wid2=wids(kfc1,4)

              ELSE

                wid2=wids(kfc1,5)

              ENDIF

              IF(kfd2.GT.0) THEN

                wid2=wid2*wids(kfc2,2)

              ELSEIF(kfd2.LT.0) THEN

                wid2=wid2*wids(kfc2,3)

              ENDIF

            ELSEIF(kfd3.EQ.-kfd1) THEN

              wid2=wids(kfc1,1)

              IF(kfd2.GT.0) THEN

                wid2=wid2*wids(kfc2,2)

              ELSEIF(kfd2.LT.0) THEN

                wid2=wid2*wids(kfc2,3)

              ENDIF

            ELSEIF(kfd3.EQ.kfd2) THEN

              IF(kchg(kfc2,3).EQ.0) THEN

                wid2=wids(kfc2,1)

              ELSEIF(kfd2.GT.0) THEN

                wid2=wids(kfc2,4)

              ELSE

                wid2=wids(kfc2,5)

              ENDIF

              IF(kfd1.GT.0) THEN

                wid2=wid2*wids(kfc1,2)

              ELSEIF(kfd1.LT.0) THEN

                wid2=wid2*wids(kfc1,3)

              ENDIF

            ELSEIF(kfd3.EQ.-kfd2) THEN

              wid2=wids(kfc2,1)

              IF(kfd1.GT.0) THEN

                wid2=wid2*wids(kfc1,2)

              ELSEIF(kfd1.LT.0) THEN

                wid2=wid2*wids(kfc1,3)

              ENDIF

            ELSE

              IF(kfd1.GT.0) THEN

                wid2=wids(kfc1,2)

              ELSE

                wid2=wids(kfc1,3)

              ENDIF

              IF(kfd2.GT.0) THEN

                wid2=wid2*wids(kfc2,2)

              ELSE

                wid2=wid2*wids(kfc2,3)

              ENDIF

              IF(kfd3.GT.0) THEN

                wid2=wid2*wids(kfc3,2)

              ELSEIF(kfd3.LT.0) THEN

                wid2=wid2*wids(kfc3,3)

              ENDIF

            ENDIF


C...Store effective widths according to case.

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  120   CONTINUE

C...Return.

        mint(61)=0

        mint(62)=0

        mint(63)=0

        RETURN

      ENDIF


C...Here begins detailed dynamical calculation of resonance widths.

C...Shared treatment of Higgs states.

      kfhigg=25

      ihigg=1

      IF(kfla.EQ.35.OR.kfla.EQ.36) THEN

        kfhigg=kfla

        ihigg=kfla-33

      ENDIF


C...Common electroweak and strong constants.

      xw=paru(102)

      xwv=xw

      IF(mstp(8).GE.2) xw=1d0-(pmas(24,1)/pmas(23,1))**2

      xw1=1d0-xw

      aem=pyalem(sh)

      IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)

      as=pyalps(sh)

      radc=1d0+as/paru(1)


      IF(kfla.EQ.6) THEN

C...t quark.

        fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr

        radct=1d0-2.5d0*as/paru(1)

        DO 130 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 130

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 130

          IF(i.GE.4.AND.i.LE.7) THEN

C...t -> W + q; including approximate QCD correction factor.

            wdtp(i)=fac*vckm(3,i-3)*radct*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)

            IF(kflr.GT.0) THEN

              wid2=wids(24,2)

              IF(i.EQ.7) wid2=wid2*wids(7,2)

            ELSE

              wid2=wids(24,3)

              IF(i.EQ.7) wid2=wid2*wids(7,3)

            ENDIF

          ELSEIF(i.EQ.9) THEN

C...t -> H + b.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)

            wid2=wids(37,2)

            IF(kflr.LT.0) wid2=wids(37,3)

CMRENNA++

          ELSEIF(i.GE.10.AND.i.LE.13.AND.imss(1).NE.0) THEN

C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.

            beta=atan(rmss(5))

            sinb=sin(beta)

            tanw=sqrt(paru(102)/(1d0-paru(102)))

            et=kchg(6,1)/3d0

            t3l=sign(0.5d0,et)

            kfc1=pycomp(kfdp(idc,1))

            kfc2=pycomp(kfdp(idc,2))

            pmnchi=pmas(kfc1,1)

            pmstop=pmas(kfc2,1)

            IF(shr.GT.pmnchi+pmstop) THEN

              iz=i-9

              al=shr*zmix(iz,4)/(2.0d0*pmas(24,1)*sinb)

              ar=-et*zmix(iz,1)*tanw

              bl=t3l*(zmix(iz,2)-zmix(iz,1)*tanw)-ar

              br=al

              fl=sfmix(6,1)*al+sfmix(6,2)*ar

              fr=sfmix(6,1)*bl+sfmix(6,2)*br

              pcm=sqrt((sh-(pmnchi+pmstop)**2)*

     &        (sh-(pmnchi-pmstop)**2))/(2d0*shr)

              wdtp(i)=(0.5d0*pyalem(sh)/paru(102))*pcm*((fl**2+fr**2)*

     &        (sh+pmnchi**2-pmstop**2)+smz(iz)*4d0*shr*fl*fr)

              IF(kflr.GT.0) THEN

                wid2=wids(kfc1,2)*wids(kfc2,2)

              ELSE

                wid2=wids(kfc1,2)*wids(kfc2,3)

              ENDIF

            ENDIF

CMRENNA--

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  130   CONTINUE


      ELSEIF(kfla.EQ.7) THEN

C...b' quark.

        fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr

        DO 140 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 140

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 140

          IF(i.GE.4.AND.i.LE.7) THEN

C...b' -> W + q.

            wdtp(i)=fac*vckm(i-3,4)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)

            IF(kflr.GT.0) THEN

              wid2=wids(24,3)

              IF(i.EQ.6) wid2=wid2*wids(6,2)

              IF(i.EQ.7) wid2=wid2*wids(8,2)

            ELSE

              wid2=wids(24,2)

              IF(i.EQ.6) wid2=wid2*wids(6,3)

              IF(i.EQ.7) wid2=wid2*wids(8,3)

            ENDIF

            wid2=wids(24,3)

            IF(kflr.LT.0) wid2=wids(24,2)

          ELSEIF(i.EQ.9.OR.i.EQ.10) THEN

C...b' -> H + q.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)

            IF(kflr.GT.0) THEN

              wid2=wids(37,3)

              IF(i.EQ.10) wid2=wid2*wids(6,2)

            ELSE

              wid2=wids(37,2)

              IF(i.EQ.10) wid2=wid2*wids(6,3)

            ENDIF

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  140   CONTINUE


      ELSEIF(kfla.EQ.8) THEN

C...t' quark.

        fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr

        DO 150 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 150

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 150

          IF(i.GE.4.AND.i.LE.7) THEN

C...t' -> W + q.

            wdtp(i)=fac*vckm(4,i-3)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)

            IF(kflr.GT.0) THEN

              wid2=wids(24,2)

              IF(i.EQ.7) wid2=wid2*wids(7,2)

            ELSE

              wid2=wids(24,3)

              IF(i.EQ.7) wid2=wid2*wids(7,3)

            ENDIF

          ELSEIF(i.EQ.9.OR.i.EQ.10) THEN

C...t' -> H + q.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)

            IF(kflr.GT.0) THEN

              wid2=wids(37,2)

              IF(i.EQ.10) wid2=wid2*wids(7,2)

            ELSE

              wid2=wids(37,3)

              IF(i.EQ.10) wid2=wid2*wids(7,3)

            ENDIF

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  150   CONTINUE


      ELSEIF(kfla.EQ.17) THEN

C...tau' lepton.

        fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr

        DO 160 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 160

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 160

          IF(i.EQ.3) THEN

C...tau' -> W + nu'_tau.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)

            IF(kflr.GT.0) THEN

              wid2=wids(24,3)

              wid2=wid2*wids(18,2)

            ELSE

              wid2=wids(24,2)

              wid2=wid2*wids(18,3)

            ENDIF

          ELSEIF(i.EQ.5) THEN

C...tau' -> H + nu'_tau.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0+rm2-rm1)*(paru(141)**2+rm2/paru(141)**2)+4d0*rm2)

            IF(kflr.GT.0) THEN

              wid2=wids(37,3)

              wid2=wid2*wids(18,2)

            ELSE

              wid2=wids(37,2)

              wid2=wid2*wids(18,3)

            ENDIF

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  160   CONTINUE


      ELSEIF(kfla.EQ.18) THEN

C...nu'_tau neutrino.

        fac=(aem/(16d0*xw))*(sh/pmas(24,1)**2)*shr

        DO 170 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 170

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 170

          IF(i.EQ.2) THEN

C...nu'_tau -> W + tau'.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0-rm2)**2+(1d0+rm2)*rm1-2d0*rm1**2)

            IF(kflr.GT.0) THEN

              wid2=wids(24,2)

              wid2=wid2*wids(17,2)

            ELSE

              wid2=wids(24,3)

              wid2=wid2*wids(17,3)

            ENDIF

          ELSEIF(i.EQ.3) THEN

C...nu'_tau -> H + tau'.

            wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))*

     &      ((1d0+rm2-rm1)*(rm2*paru(141)**2+1d0/paru(141)**2)+4d0*rm2)

            IF(kflr.GT.0) THEN

              wid2=wids(37,2)

              wid2=wid2*wids(17,2)

            ELSE

              wid2=wids(37,3)

              wid2=wid2*wids(17,3)

            ENDIF

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  170   CONTINUE


      ELSEIF(kfla.EQ.21) THEN

C...QCD:

C***Note that widths are not given in dimensional quantities here.

        DO 180 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 180

          rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh

          rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 180

          wid2=1d0

          IF(i.LE.8) THEN

C...QCD -> q + qbar

            wdtp(i)=(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))

            IF(i.EQ.6) wid2=wids(6,1)

            IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  180   CONTINUE


      ELSEIF(kfla.EQ.22) THEN

C...QED photon.

C***Note that widths are not given in dimensional quantities here.

        DO 190 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 190

          rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh

          rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 190

          wid2=1d0

          IF(i.LE.8) THEN

C...QED -> q + qbar.

            ef=kchg(i,1)/3d0

            fcof=3d0*radc

            IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)

            wdtp(i)=fcof*ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))

            IF(i.EQ.6) wid2=wids(6,1)

            IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)

          ELSEIF(i.LE.12) THEN

C...QED -> l+ + l-.

            ef=kchg(9+2*(i-8),1)/3d0

            wdtp(i)=ef**2*(1d0+2d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))

            IF(i.EQ.12) wid2=wids(17,1)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  190   CONTINUE


      ELSEIF(kfla.EQ.23) THEN

C...Z0:

        icase=1

        xwc=1d0/(16d0*xw*xw1)

        fac=(aem*xwc/3d0)*shr

  200   CONTINUE

        IF(mint(61).GE.1.AND.icase.EQ.2) THEN

          vint(111)=0d0

          vint(112)=0d0

          vint(114)=0d0

        ENDIF

        IF(mint(61).EQ.1.AND.icase.EQ.2) THEN

          kfi=iabs(mint(15))

          IF(kfi.GT.20) kfi=iabs(mint(16))

          ei=kchg(kfi,1)/3d0

          ai=sign(1d0,ei)

          vi=ai-4d0*ei*xwv

          sqmz=pmas(23,1)**2

          hz=shr*wdtp(0)

          IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=1d0

          IF(mstp(43).EQ.3) vint(112)=

     &    2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)

          IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=

     &    xwc**2*sh**2/((sh-sqmz)**2+hz**2)

        ENDIF

        DO 210 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 210

          rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh

          rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 210

          wid2=1d0

          IF(i.LE.8) THEN

C...Z0 -> q + qbar

            ef=kchg(i,1)/3d0

            af=sign(1d0,ef+0.1d0)

            vf=af-4d0*ef*xwv

            fcof=3d0*radc

            IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*pyhfth(sh,sh*rm1,1d0)

            IF(i.EQ.6) wid2=wids(6,1)

            IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)

          ELSEIF(i.LE.16) THEN

C...Z0 -> l+ + l-, nu + nubar

            ef=kchg(i+2,1)/3d0

            af=sign(1d0,ef+0.1d0)

            vf=af-4d0*ef*xwv

            fcof=1d0

            IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)

          ENDIF

          be34=sqrt(max(0d0,1d0-4d0*rm1))

          IF(icase.EQ.1) THEN

            wdtp(i)=fac*fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*

     &      be34

          ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

            wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*

     &      ef*vf+(vi**2+ai**2)*vint(114)*vf**2)*(1d0+2d0*rm1)+

     &      (vi**2+ai**2)*vint(114)*af**2*(1d0-4d0*rm1))*be34

          ELSEIF(mint(61).EQ.2.AND.icase.EQ.2) THEN

            fggf=fcof*ef**2*(1d0+2d0*rm1)*be34

            fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34

            fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34

          ENDIF

          IF(icase.EQ.1) wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            IF((icase.EQ.1.AND.mint(61).NE.1).OR.

     &      (icase.EQ.2.AND.mint(61).EQ.1)) THEN

              wdte(i,mdme(idc,1))=wdtp(i)*wid2

              wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+

     &        wdte(i,mdme(idc,1))

              wdte(i,0)=wdte(i,mdme(idc,1))

              wdte(0,0)=wdte(0,0)+wdte(i,0)

            ENDIF

            IF(mint(61).EQ.2.AND.icase.EQ.2) THEN

              IF(mstp(43).EQ.1.OR.mstp(43).EQ.3) vint(111)=

     &        vint(111)+fggf*wid2

              IF(mstp(43).EQ.3) vint(112)=vint(112)+fgzf*wid2

              IF(mstp(43).EQ.2.OR.mstp(43).EQ.3) vint(114)=

     &        vint(114)+fzzf*wid2

            ENDIF

          ENDIF

  210   CONTINUE

        IF(mint(61).GE.1) icase=3-icase

        IF(icase.EQ.2) goto 200


      ELSEIF(kfla.EQ.24) THEN

C...W+/-:

        fac=(aem/(24d0*xw))*shr

        DO 220 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 220

          rm1=pmas(iabs(kfdp(idc,1)),1)**2/sh

          rm2=pmas(iabs(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 220

          wid2=1d0

          IF(i.LE.16) THEN

C...W+/- -> q + qbar'

            fcof=3d0*radc*vckm((i-1)/4+1,mod(i-1,4)+1)

            IF(kflr.GT.0) THEN

              IF(mod(i,4).EQ.3) wid2=wids(6,2)

              IF(mod(i,4).EQ.0) wid2=wids(8,2)

              IF(i.GE.13) wid2=wid2*wids(7,3)

            ELSE

              IF(mod(i,4).EQ.3) wid2=wids(6,3)

              IF(mod(i,4).EQ.0) wid2=wids(8,3)

              IF(i.GE.13) wid2=wid2*wids(7,2)

            ENDIF

          ELSEIF(i.LE.20) THEN

C...W+/- -> l+/- + nu

            fcof=1d0

            IF(kflr.GT.0) THEN

              IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)

            ELSE

              IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)

            ENDIF

          ENDIF

          wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*

     &    sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  220   CONTINUE


      ELSEIF(kfla.EQ.25.OR.kfla.EQ.35.OR.kfla.EQ.36) THEN

C...h0 (or H0, or A0):

        IF(mstp(49).EQ.0) THEN

          fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr

        ELSE

          fac=(aem/(8d0*xw))*(pmas(kfhigg,1)/pmas(24,1))**2*shr

        ENDIF

        DO 260 i=1,mdcy(kfhigg,3)

          idc=i+mdcy(kfhigg,2)-1

          IF(mdme(idc,1).LT.0) goto 260

          kfc1=pycomp(kfdp(idc,1))

          kfc2=pycomp(kfdp(idc,2))

          rm1=pmas(kfc1,1)**2/sh

          rm2=pmas(kfc2,1)**2/sh

          IF(i.NE.16.AND.i.NE.17.AND.sqrt(rm1)+sqrt(rm2).GT.1d0)

     &    goto 260

          wid2=1d0


          IF(i.LE.8) THEN

C...h0 -> q + qbar

            wdtp(i)=fac*3d0*rm1*(1d0-4d0*rm1)*sqrt(max(0d0,

     &      1d0-4d0*rm1))*radc

            IF(mstp(37).EQ.1.AND.mstp(2).GE.1) wdtp(i)=wdtp(i)*

     &      (log(max(4d0,parp(37)**2*rm1*sh/paru(117)**2))/

     &      log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

            IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

              IF(mod(i,2).EQ.1) wdtp(i)=wdtp(i)*paru(151+10*ihigg)**2

              IF(mod(i,2).EQ.0) wdtp(i)=wdtp(i)*paru(152+10*ihigg)**2

            ENDIF

            IF(i.EQ.6) wid2=wids(6,1)

            IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)


          ELSEIF(i.LE.12) THEN

C...h0 -> l+ + l-

            wdtp(i)=fac*rm1*(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))

            IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*

     &      paru(153+10*ihigg)**2

            IF(i.EQ.12) wid2=wids(17,1)


          ELSEIF(i.EQ.13) THEN

C...h0 -> g + g; quark loop contribution only

            etare=0d0

            etaim=0d0

            DO 230 j=1,2*mstp(1)

              eps=(2d0*pmas(j,1))**2/sh

C...Loop integral; function of eps=4m^2/shat; different for A0.

              IF(eps.LE.1d0) THEN

                IF(eps.GT.1.d-4) THEN

                  root=sqrt(1d0-eps)

                  rln=log((1d0+root)/(1d0-root))

                ELSE

                  rln=log(4d0/eps-2d0)

                ENDIF

                phire=-0.25d0*(rln**2-paru(1)**2)

                phiim=0.5d0*paru(1)*rln

              ELSE

                phire=(asin(1d0/sqrt(eps)))**2

                phiim=0d0

              ENDIF

              IF(ihigg.LE.2) THEN

                etarej=-0.5d0*eps*(1d0+(1d0-eps)*phire)

                etaimj=-0.5d0*eps*(1d0-eps)*phiim

              ELSE

                etarej=-0.5d0*eps*phire

                etaimj=-0.5d0*eps*phiim

              ENDIF

C...Couplings (=1 for standard model Higgs).

              IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

                IF(mod(j,2).EQ.1) THEN

                  etarej=etarej*paru(151+10*ihigg)

                  etaimj=etaimj*paru(151+10*ihigg)

                ELSE

                  etarej=etarej*paru(152+10*ihigg)

                  etaimj=etaimj*paru(152+10*ihigg)

                ENDIF

              ENDIF

              etare=etare+etarej

              etaim=etaim+etaimj

  230       CONTINUE

            eta2=etare**2+etaim**2

            wdtp(i)=fac*(as/paru(1))**2*eta2


          ELSEIF(i.EQ.14) THEN

C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions

            etare=0d0

            etaim=0d0

            jmax=3*mstp(1)+1

            IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1

            DO 240 j=1,jmax

              IF(j.LE.2*mstp(1)) THEN

                ej=kchg(j,1)/3d0

                eps=(2d0*pmas(j,1))**2/sh

              ELSEIF(j.LE.3*mstp(1)) THEN

                jl=2*(j-2*mstp(1))-1

                ej=kchg(10+jl,1)/3d0

                eps=(2d0*pmas(10+jl,1))**2/sh

              ELSEIF(j.EQ.3*mstp(1)+1) THEN

                eps=(2d0*pmas(24,1))**2/sh

              ELSE

                eps=(2d0*pmas(37,1))**2/sh

              ENDIF

C...Loop integral; function of eps=4m^2/shat.

              IF(eps.LE.1d0) THEN

                IF(eps.GT.1.d-4) THEN

                  root=sqrt(1d0-eps)

                  rln=log((1d0+root)/(1d0-root))

                ELSE

                  rln=log(4d0/eps-2d0)

                ENDIF

                phire=-0.25d0*(rln**2-paru(1)**2)

                phiim=0.5d0*paru(1)*rln

              ELSE

                phire=(asin(1d0/sqrt(eps)))**2

                phiim=0d0

              ENDIF

              IF(j.LE.3*mstp(1)) THEN

C...Fermion loops: loop integral different for A0; charges.

                IF(ihigg.LE.2) THEN

                  phipre=-0.5d0*eps*(1d0+(1d0-eps)*phire)

                  phipim=-0.5d0*eps*(1d0-eps)*phiim

                ELSE

                  phipre=-0.5d0*eps*phire

                  phipim=-0.5d0*eps*phiim

                ENDIF

                IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN

                  ejc=3d0*ej**2

                  ejh=paru(151+10*ihigg)

                ELSEIF(j.LE.2*mstp(1)) THEN

                  ejc=3d0*ej**2

                  ejh=paru(152+10*ihigg)

                ELSE

                  ejc=ej**2

                  ejh=paru(153+10*ihigg)

                ENDIF

                IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0

                etarej=ejc*ejh*phipre

                etaimj=ejc*ejh*phipim

              ELSEIF(j.EQ.3*mstp(1)+1) THEN

C...W loops: loop integral and charges.

                etarej=0.5d0+0.75d0*eps*(1d0+(2d0-eps)*phire)

                etaimj=0.75d0*eps*(2d0-eps)*phiim

                IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

                  etarej=etarej*paru(155+10*ihigg)

                  etaimj=etaimj*paru(155+10*ihigg)

                ENDIF

              ELSE

C...Charged H loops: loop integral and charges.

                fachhh=(pmas(24,1)/pmas(37,1))**2*

     &          paru(158+10*ihigg+2*(ihigg/3))

                etarej=eps*(1d0-eps*phire)*fachhh

                etaimj=-eps**2*phiim*fachhh

              ENDIF

              etare=etare+etarej

              etaim=etaim+etaimj

  240       CONTINUE

            eta2=etare**2+etaim**2

            wdtp(i)=fac*(aem/paru(1))**2*0.5d0*eta2


          ELSEIF(i.EQ.15) THEN

C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions

            etare=0d0

            etaim=0d0

            jmax=3*mstp(1)+1

            IF(mstp(4).GE.1.OR.ihigg.GE.2) jmax=jmax+1

            DO 250 j=1,jmax

              IF(j.LE.2*mstp(1)) THEN

                ej=kchg(j,1)/3d0

                aj=sign(1d0,ej+0.1d0)

                vj=aj-4d0*ej*xwv

                eps=(2d0*pmas(j,1))**2/sh

                epsp=(2d0*pmas(j,1)/pmas(23,1))**2

              ELSEIF(j.LE.3*mstp(1)) THEN

                jl=2*(j-2*mstp(1))-1

                ej=kchg(10+jl,1)/3d0

                aj=sign(1d0,ej+0.1d0)

                vj=aj-4d0*ej*xwv

                eps=(2d0*pmas(10+jl,1))**2/sh

                epsp=(2d0*pmas(10+jl,1)/pmas(23,1))**2

              ELSE

                eps=(2d0*pmas(24,1))**2/sh

                epsp=(2d0*pmas(24,1)/pmas(23,1))**2

              ENDIF

C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.

              IF(eps.LE.1d0) THEN

                root=sqrt(1d0-eps)

                IF(eps.GT.1.d-4) THEN

                  rln=log((1d0+root)/(1d0-root))

                ELSE

                  rln=log(4d0/eps-2d0)

                ENDIF

                phire=-0.25d0*(rln**2-paru(1)**2)

                phiim=0.5d0*paru(1)*rln

                psire=0.5d0*root*rln

                psiim=-0.5d0*root*paru(1)

              ELSE

                phire=(asin(1d0/sqrt(eps)))**2

                phiim=0d0

                psire=sqrt(eps-1d0)*asin(1d0/sqrt(eps))

                psiim=0d0

              ENDIF

              IF(epsp.LE.1d0) THEN

                root=sqrt(1d0-epsp)

                IF(epsp.GT.1.d-4) THEN

                  rln=log((1d0+root)/(1d0-root))

                ELSE

                  rln=log(4d0/epsp-2d0)

                ENDIF

                phirep=-0.25d0*(rln**2-paru(1)**2)

                phiimp=0.5d0*paru(1)*rln

                psirep=0.5d0*root*rln

                psiimp=-0.5d0*root*paru(1)

              ELSE

                phirep=(asin(1d0/sqrt(epsp)))**2

                phiimp=0d0

                psirep=sqrt(epsp-1d0)*asin(1d0/sqrt(epsp))

                psiimp=0d0

              ENDIF

              fxyre=eps*epsp/(8d0*(eps-epsp))*(1d0+eps*epsp/(eps-epsp)*

     &        (phire-phirep)+2d0*eps/(eps-epsp)*(psire-psirep))

              fxyim=eps**2*epsp/(8d0*(eps-epsp)**2)*

     &        (epsp*(phiim-phiimp)+2d0*(psiim-psiimp))

              f1re=-eps*epsp/(2d0*(eps-epsp))*(phire-phirep)

              f1im=-eps*epsp/(2d0*(eps-epsp))*(phiim-phiimp)

              IF(j.LE.3*mstp(1)) THEN

C...Fermion loops: loop integral different for A0; charges.

                IF(ihigg.EQ.3) fxyre=0d0

                IF(ihigg.EQ.3) fxyim=0d0

                IF(j.LE.2*mstp(1).AND.mod(j,2).EQ.1) THEN

                  ejc=-3d0*ej*vj

                  ejh=paru(151+10*ihigg)

                ELSEIF(j.LE.2*mstp(1)) THEN

                  ejc=-3d0*ej*vj

                  ejh=paru(152+10*ihigg)

                ELSE

                  ejc=-ej*vj

                  ejh=paru(153+10*ihigg)

                ENDIF

                IF(mstp(4).EQ.0.AND.ihigg.EQ.1) ejh=1d0

                etarej=ejc*ejh*(fxyre-0.25d0*f1re)

                etaimj=ejc*ejh*(fxyim-0.25d0*f1im)

              ELSEIF(j.EQ.3*mstp(1)+1) THEN

C...W loops: loop integral and charges.

                heps=(1d0+2d0/eps)*xw/xw1-(5d0+2d0/eps)

                etarej=-xw1*((3d0-xw/xw1)*f1re+heps*fxyre)

                etaimj=-xw1*((3d0-xw/xw1)*f1im+heps*fxyim)

                IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

                  etarej=etarej*paru(155+10*ihigg)

                  etaimj=etaimj*paru(155+10*ihigg)

                ENDIF

              ELSE

C...Charged H loops: loop integral and charges.

                fachhh=(pmas(24,1)/pmas(37,1))**2*(1d0-2d0*xw)*

     &          paru(158+10*ihigg+2*(ihigg/3))

                etarej=fachhh*fxyre

                etaimj=fachhh*fxyim

              ENDIF

              etare=etare+etarej

              etaim=etaim+etaimj

  250       CONTINUE

            eta2=(etare**2+etaim**2)/(xw*xw1)

            wdtp(i)=fac*(aem/paru(1))**2*(1d0-pmas(23,1)**2/sh)**3*eta2

            wid2=wids(23,2)


          ELSEIF(i.LE.17) THEN

C...h0 -> Z0 + Z0, W+ + W-

            pm1=pmas(iabs(kfdp(idc,1)),1)

            pg1=pmas(iabs(kfdp(idc,1)),2)

            IF(mint(62).GE.1) THEN

              IF(mstp(42).EQ.0.OR.(4d0*(pm1+10d0*pg1)**2.LT.sh.AND.

     &        ckin(46).LT.ckin(45).AND.ckin(48).LT.ckin(47).AND.

     &        max(ckin(45),ckin(47)).LT.pm1-10d0*pg1)) THEN

                mofsv(ihigg,i-15)=0

                widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,

     &          1d0-4d0*rm1))

                wid2=1d0

              ELSE

                mofsv(ihigg,i-15)=1

                rmas=sqrt(max(0d0,sh))

                CALL pyofsh(1,kfla,kfdp(idc,1),kfdp(idc,2),rmas,widw,

     &          wid2)

                widwsv(ihigg,i-15)=widw

                wid2sv(ihigg,i-15)=wid2

              ENDIF

            ELSE

              IF(mofsv(ihigg,i-15).EQ.0) THEN

                widw=(1d0-4d0*rm1+12d0*rm1**2)*sqrt(max(0d0,

     &          1d0-4d0*rm1))

                wid2=1d0

              ELSE

                widw=widwsv(ihigg,i-15)

                wid2=wid2sv(ihigg,i-15)

              ENDIF

            ENDIF

            wdtp(i)=fac*widw/(2d0*(18-i))

            IF(mstp(4).GE.1.OR.ihigg.GE.2) wdtp(i)=wdtp(i)*

     &      paru(138+i+10*ihigg)**2

            wid2=wid2*wids(7+i,1)


          ELSEIF(i.EQ.18.AND.kfla.EQ.35) THEN

C***H0 -> Z0 + h0 (not yet implemented).


          ELSEIF(i.EQ.19.AND.kfla.EQ.35) THEN

C...H0 -> h0 + h0.

            wdtp(i)=fac*paru(176)**2*0.25d0*pmas(23,1)**4/sh**2*

     &      sqrt(max(0d0,1d0-4d0*rm1))

            wid2=wids(25,2)**2


          ELSEIF(i.EQ.20.AND.kfla.EQ.35) THEN

C...H0 -> A0 + A0.

            wdtp(i)=fac*paru(177)**2*0.25d0*pmas(23,1)**4/sh**2*

     &      sqrt(max(0d0,1d0-4d0*rm1))

            wid2=wids(36,2)**2


          ELSEIF(i.EQ.18.AND.kfla.EQ.36) THEN

C...A0 -> Z0 + h0.

            wdtp(i)=fac*paru(186)**2*0.5d0*sqrt(max(0d0,

     &      (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(23,2)*wids(25,2)


CMRENNA++

          ELSE

C...Add in SUSY decays (two-body) by rescaling by phase space factor.

            rm10=rm1*sh/pmr**2

            rm20=rm2*sh/pmr**2

            wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)

            wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)

            IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN

              wfac=0d0

            ELSE

              wfac=wfac/wfac0

            ENDIF

            wdtp(i)=pmas(kfla,2)*brat(idc)*(shr/pmr)*sqrt(wfac)

CMRENNA--

            IF(kfc2.EQ.kfc1) THEN

              wid2=wids(kfc1,1)

            ELSE

              ksgn1=2

              IF(kfdp(idc,1).LT.0) ksgn1=3

              ksgn2=2

              IF(kfdp(idc,2).LT.0) ksgn2=3

              wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)

            ENDIF

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  260   CONTINUE


      ELSEIF(kfla.EQ.32) THEN

C...Z'0:

        icase=1

        xwc=1d0/(16d0*xw*xw1)

        fac=(aem*xwc/3d0)*shr

        vint(117)=0d0

  270   CONTINUE

        IF(mint(61).GE.1.AND.icase.EQ.2) THEN

          vint(111)=0d0

          vint(112)=0d0

          vint(113)=0d0

          vint(114)=0d0

          vint(115)=0d0

          vint(116)=0d0

        ENDIF

        IF(mint(61).EQ.1.AND.icase.EQ.2) THEN

          kfai=iabs(mint(15))

          ei=kchg(kfai,1)/3d0

          ai=sign(1d0,ei+0.1d0)

          vi=ai-4d0*ei*xwv

          kfaic=1

          IF(kfai.LE.10.AND.mod(kfai,2).EQ.0) kfaic=2

          IF(kfai.GT.10.AND.mod(kfai,2).NE.0) kfaic=3

          IF(kfai.GT.10.AND.mod(kfai,2).EQ.0) kfaic=4

          vpi=paru(119+2*kfaic)

          api=paru(120+2*kfaic)

          sqmz=pmas(23,1)**2

          hz=shr*fac*vint(117)

          sqmzp=pmas(32,1)**2

          hzp=shr*fac*wdtp(0)

          IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.

     &    mstp(44).EQ.7) vint(111)=1d0

          IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=

     &    2d0*xwc*sh*(sh-sqmz)/((sh-sqmz)**2+hz**2)

          IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=

     &    2d0*xwc*sh*(sh-sqmzp)/((sh-sqmzp)**2+hzp**2)

          IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.

     &    mstp(44).EQ.7) vint(114)=xwc**2*sh**2/((sh-sqmz)**2+hz**2)

          IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=

     &    2d0*xwc**2*sh**2*((sh-sqmz)*(sh-sqmzp)+hz*hzp)/

     &    (((sh-sqmz)**2+hz**2)*((sh-sqmzp)**2+hzp**2))

          IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.

     &    mstp(44).EQ.7) vint(116)=xwc**2*sh**2/((sh-sqmzp)**2+hzp**2)

        ENDIF

        DO 280 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 280

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0.OR.mdme(idc,1).LT.0) goto 280

          wid2=1d0

          IF(i.LE.16) THEN

            IF(i.LE.8) THEN

C...Z'0 -> q + qbar

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

              vpf=paru(123-2*mod(i,2))

              apf=paru(124-2*mod(i,2))

              fcof=3d0*radc

              IF(i.GE.6.AND.mstp(35).GE.1) fcof=fcof*

     &        pyhfth(sh,sh*rm1,1d0)

              IF(i.EQ.6) wid2=wids(6,1)

              IF((i.EQ.7.OR.i.EQ.8)) wid2=wids(i,1)

            ELSEIF(i.LE.16) THEN

C...Z'0 -> l+ + l-, nu + nubar

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

              vpf=paru(127-2*mod(i,2))

              apf=paru(128-2*mod(i,2))

              fcof=1d0

              IF((i.EQ.15.OR.i.EQ.16)) wid2=wids(2+i,1)

            ENDIF

            be34=sqrt(max(0d0,1d0-4d0*rm1))

            IF(icase.EQ.1) THEN

              wdtpz=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34

              wdtp(i)=fac*fcof*(vpf**2*(1d0+2d0*rm1)+

     &        apf**2*(1d0-4d0*rm1))*be34

            ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

              wdtp(i)=fac*fcof*((ei**2*vint(111)*ef**2+ei*vi*vint(112)*

     &        ef*vf+ei*vpi*vint(113)*ef*vpf+(vi**2+ai**2)*vint(114)*

     &        vf**2+(vi*vpi+ai*api)*vint(115)*vf*vpf+(vpi**2+api**2)*

     &        vint(116)*vpf**2)*(1d0+2d0*rm1)+((vi**2+ai**2)*vint(114)*

     &        af**2+(vi*vpi+ai*api)*vint(115)*af*apf+(vpi**2+api**2)*

     &        vint(116)*apf**2)*(1d0-4d0*rm1))*be34

            ELSEIF(mint(61).EQ.2) THEN

              fggf=fcof*ef**2*(1d0+2d0*rm1)*be34

              fgzf=fcof*ef*vf*(1d0+2d0*rm1)*be34

              fgzpf=fcof*ef*vpf*(1d0+2d0*rm1)*be34

              fzzf=fcof*(vf**2*(1d0+2d0*rm1)+af**2*(1d0-4d0*rm1))*be34

              fzzpf=fcof*(vf*vpf*(1d0+2d0*rm1)+af*apf*(1d0-4d0*rm1))*

     &        be34

              fzpzpf=fcof*(vpf**2*(1d0+2d0*rm1)+apf**2*(1d0-4d0*rm1))*

     &        be34

            ENDIF

          ELSEIF(i.EQ.17) THEN

C...Z'0 -> W+ + W-

            wdtpzp=paru(129)**2*xw1**2*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*

     &      (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)

            IF(icase.EQ.1) THEN

              wdtpz=0d0

              wdtp(i)=fac*wdtpzp

            ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

              wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp

            ELSEIF(mint(61).EQ.2) THEN

              fggf=0d0

              fgzf=0d0

              fgzpf=0d0

              fzzf=0d0

              fzzpf=0d0

              fzpzpf=wdtpzp

            ENDIF

            wid2=wids(24,1)

          ELSEIF(i.EQ.18) THEN

C...Z'0 -> H+ + H-

            czc=2d0*(1d0-2d0*xw)

            be34c=(1d0-4d0*rm1)*sqrt(max(0d0,1d0-4d0*rm1))

            IF(icase.EQ.1) THEN

              wdtpz=0.25d0*paru(142)**2*czc**2*be34c

              wdtp(i)=fac*0.25d0*paru(143)**2*czc**2*be34c

            ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

              wdtp(i)=fac*0.25d0*(ei**2*vint(111)+paru(142)*ei*vi*

     &        vint(112)*czc+paru(143)*ei*vpi*vint(113)*czc+paru(142)**2*

     &        (vi**2+ai**2)*vint(114)*czc**2+paru(142)*paru(143)*

     &        (vi*vpi+ai*api)*vint(115)*czc**2+paru(143)**2*

     &        (vpi**2+api**2)*vint(116)*czc**2)*be34c

            ELSEIF(mint(61).EQ.2) THEN

              fggf=0.25d0*be34c

              fgzf=0.25d0*paru(142)*czc*be34c

              fgzpf=0.25d0*paru(143)*czc*be34c

              fzzf=0.25d0*paru(142)**2*czc**2*be34c

              fzzpf=0.25d0*paru(142)*paru(143)*czc**2*be34c

              fzpzpf=0.25d0*paru(143)**2*czc**2*be34c

            ENDIF

            wid2=wids(37,1)

          ELSEIF(i.EQ.19) THEN

C...Z'0 -> Z0 + gamma.

          ELSEIF(i.EQ.20) THEN

C...Z'0 -> Z0 + h0

            flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

            wdtpzp=paru(145)**2*4d0*abs(1d0-2d0*xw)*

     &      (3d0*rm1+0.25d0*flam**2)*flam

            IF(icase.EQ.1) THEN

              wdtpz=0d0

              wdtp(i)=fac*wdtpzp

            ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

              wdtp(i)=fac*(vpi**2+api**2)*vint(116)*wdtpzp

            ELSEIF(mint(61).EQ.2) THEN

              fggf=0d0

              fgzf=0d0

              fgzpf=0d0

              fzzf=0d0

              fzzpf=0d0

              fzpzpf=wdtpzp

            ENDIF

            wid2=wids(23,2)*wids(25,2)

          ELSEIF(i.EQ.21.OR.i.EQ.22) THEN

C...Z' -> h0 + A0 or H0 + A0.

            be34c=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(i.EQ.21) THEN

              czah=paru(186)

              czpah=paru(188)

            ELSE

              czah=paru(187)

              czpah=paru(189)

            ENDIF

            IF(icase.EQ.1) THEN

              wdtpz=czah**2*be34c

              wdtp(i)=fac*czpah**2*be34c

            ELSEIF(mint(61).EQ.1.AND.icase.EQ.2) THEN

              wdtp(i)=fac*(czah**2*(vi**2+ai**2)*vint(114)+czah*czpah*

     &        (vi*vpi+ai*api)*vint(115)+czpah**2*(vpi**2+api**2)*

     &        vint(116))*be34c

            ELSEIF(mint(61).EQ.2) THEN

              fggf=0d0

              fgzf=0d0

              fgzpf=0d0

              fzzf=czah**2*be34c

              fzzpf=czah*czpah*be34c

              fzpzpf=czpah**2*be34c

            ENDIF

            IF(i.EQ.21) wid2=wids(25,2)*wids(36,2)

            IF(i.EQ.22) wid2=wids(35,2)*wids(36,2)

          ENDIF

          IF(icase.EQ.1) THEN

            vint(117)=vint(117)+wdtpz

            wdtp(0)=wdtp(0)+wdtp(i)

          ENDIF

          IF(mdme(idc,1).GT.0) THEN

            IF((icase.EQ.1.AND.mint(61).NE.1).OR.

     &      (icase.EQ.2.AND.mint(61).EQ.1)) THEN

              wdte(i,mdme(idc,1))=wdtp(i)*wid2

              wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+

     &        wdte(i,mdme(idc,1))

              wdte(i,0)=wdte(i,mdme(idc,1))

              wdte(0,0)=wdte(0,0)+wdte(i,0)

            ENDIF

            IF(mint(61).EQ.2.AND.icase.EQ.2) THEN

              IF(mstp(44).EQ.1.OR.mstp(44).EQ.4.OR.mstp(44).EQ.5.OR.

     &        mstp(44).EQ.7) vint(111)=vint(111)+fggf*wid2

              IF(mstp(44).EQ.4.OR.mstp(44).EQ.7) vint(112)=vint(112)+

     &        fgzf*wid2

              IF(mstp(44).EQ.5.OR.mstp(44).EQ.7) vint(113)=vint(113)+

     &        fgzpf*wid2

              IF(mstp(44).EQ.2.OR.mstp(44).EQ.4.OR.mstp(44).EQ.6.OR.

     &        mstp(44).EQ.7) vint(114)=vint(114)+fzzf*wid2

              IF(mstp(44).EQ.6.OR.mstp(44).EQ.7) vint(115)=vint(115)+

     &        fzzpf*wid2

              IF(mstp(44).EQ.3.OR.mstp(44).EQ.5.OR.mstp(44).EQ.6.OR.

     &        mstp(44).EQ.7) vint(116)=vint(116)+fzpzpf*wid2

            ENDIF

          ENDIF

  280   CONTINUE

        IF(mint(61).GE.1) icase=3-icase

        IF(icase.EQ.2) goto 270


      ELSEIF(kfla.EQ.34) THEN

C...W'+/-:

        fac=(aem/(24d0*xw))*shr

        DO 290 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 290

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 290

          wid2=1d0

          IF(i.LE.20) THEN

            IF(i.LE.16) THEN

C...W'+/- -> q + qbar'

              fcof=3d0*radc*(paru(131)**2+paru(132)**2)*

     &        vckm((i-1)/4+1,mod(i-1,4)+1)

              IF(kflr.GT.0) THEN

                IF(mod(i,4).EQ.3) wid2=wids(6,2)

                IF(mod(i,4).EQ.0) wid2=wids(8,2)

                IF(i.GE.13) wid2=wid2*wids(7,3)

              ELSE

                IF(mod(i,4).EQ.3) wid2=wids(6,3)

                IF(mod(i,4).EQ.0) wid2=wids(8,3)

                IF(i.GE.13) wid2=wid2*wids(7,2)

              ENDIF

            ELSEIF(i.LE.20) THEN

C...W'+/- -> l+/- + nu

              fcof=paru(133)**2+paru(134)**2

              IF(kflr.GT.0) THEN

                IF(i.EQ.20) wid2=wids(17,3)*wids(18,2)

              ELSE

                IF(i.EQ.20) wid2=wids(17,2)*wids(18,3)

              ENDIF

            ENDIF

            wdtp(i)=fac*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

          ELSEIF(i.EQ.21) THEN

C...W'+/- -> W+/- + Z0

            wdtp(i)=fac*paru(135)**2*0.5d0*xw1*(rm1/rm2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3*

     &      (1d0+10d0*rm1+10d0*rm2+rm1**2+rm2**2+10d0*rm1*rm2)

            IF(kflr.GT.0) wid2=wids(24,2)*wids(23,2)

            IF(kflr.LT.0) wid2=wids(24,3)*wids(23,2)

          ELSEIF(i.EQ.23) THEN

C...W'+/- -> W+/- + h0

            flam=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

            wdtp(i)=fac*paru(146)**2*2d0*(3d0*rm1+0.25d0*flam**2)*flam

            IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)

            IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  290   CONTINUE


      ELSEIF(kfla.EQ.37) THEN

C...H+/-:

        fac=(aem/(8d0*xw))*(sh/pmas(24,1)**2)*shr

        DO 300 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 300

          kfc1=pycomp(kfdp(idc,1))

          kfc2=pycomp(kfdp(idc,2))

          rm1=pmas(kfc1,1)**2/sh

          rm2=pmas(kfc2,1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 300

          wid2=1d0

          IF(i.LE.4) THEN

C...H+/- -> q + qbar'

            rm1r=rm1

            IF(mstp(37).EQ.1.AND.mstp(2).GE.1) rm1r=rm1*

     &      (log(max(4d0,parp(37)**2*rm1*sh/paru(117)**2))/

     &      log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

            wdtp(i)=fac*3d0*radc*((rm1r*paru(141)**2+rm2/paru(141)**2)*

     &      (1d0-rm1r-rm2)-4d0*rm1r*rm2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

            IF(kflr.GT.0) THEN

              IF(i.EQ.3) wid2=wids(6,2)

              IF(i.EQ.4) wid2=wids(7,3)*wids(8,2)

            ELSE

              IF(i.EQ.3) wid2=wids(6,3)

              IF(i.EQ.4) wid2=wids(7,2)*wids(8,3)

            ENDIF

          ELSEIF(i.LE.8) THEN

C...H+/- -> l+/- + nu

            wdtp(i)=fac*((rm1*paru(141)**2+rm2/paru(141)**2)*

     &      (1d0-rm1-rm2)-4d0*rm1*rm2)*sqrt(max(0d0,(1d0-rm1-rm2)**2-

     &      4d0*rm1*rm2))

            IF(kflr.GT.0) THEN

              IF(i.EQ.8) wid2=wids(17,3)*wids(18,2)

            ELSE

              IF(i.EQ.8) wid2=wids(17,2)*wids(18,3)

            ENDIF

          ELSEIF(i.EQ.9) THEN

C...H+/- -> W+/- + h0.

            wdtp(i)=fac*paru(195)**2*0.5d0*sqrt(max(0d0,

     &      (1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(kflr.GT.0) wid2=wids(24,2)*wids(25,2)

            IF(kflr.LT.0) wid2=wids(24,3)*wids(25,2)


CMRENNA++

          ELSE

C...Add in SUSY decays (two-body) by rescaling by phase space factor.

            rm10=rm1*sh/pmr**2

            rm20=rm2*sh/pmr**2

            wfac0=1d0+rm10**2+rm20**2-2d0*(rm10+rm20+rm10*rm20)

            wfac=1d0+rm1**2+rm2**2-2d0*(rm1+rm2+rm1*rm2)

            IF(wfac.LE.0d0 .OR. wfac0.LE.0d0) THEN

              wfac=0d0

            ELSE

              wfac=wfac/wfac0

            ENDIF

            wdtp(i)=pmas(kc,2)*brat(idc)*(shr/pmr)*sqrt(wfac)

CMRENNA--

            ksgn1=2

            IF(kfls*kfdp(idc,1).LT.0.AND.kchg(kfc1,3).EQ.1) ksgn1=3

            ksgn2=2

            IF(kfls*kfdp(idc,2).LT.0.AND.kchg(kfc2,3).EQ.1) ksgn2=3

            wid2=wids(kfc1,ksgn1)*wids(kfc2,ksgn2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  300   CONTINUE


      ELSEIF(kfla.EQ.38) THEN

C...Techni-eta.

        fac=(sh/parp(46)**2)*shr

        DO 310 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 310

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 310

          wid2=1d0

          IF(i.LE.2) THEN

            wdtp(i)=fac*rm1*sqrt(max(0d0,1d0-4d0*rm1))/(4d0*paru(1))

            IF(i.EQ.2) wid2=wids(6,1)

          ELSE

            wdtp(i)=fac*5d0*as**2/(96d0*paru(1)**3)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  310   CONTINUE


      ELSEIF(kfla.EQ.39) THEN

C...LQ (leptoquark).

        fac=(aem/4d0)*paru(151)*shr

        DO 320 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 320

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 320

          wdtp(i)=fac*sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

          wid2=1d0

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  320   CONTINUE


      ELSEIF(kfla.EQ.40) THEN

C...R:

        fac=(aem/(12d0*xw))*shr

        DO 330 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 330

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 330

          wid2=1d0

          IF(i.LE.6) THEN

C...R -> q + qbar'

            fcof=3d0*radc

          ELSEIF(i.LE.9) THEN

C...R -> l+ + l'-

            fcof=1d0

          ENDIF

          wdtp(i)=fac*fcof*(2d0-rm1-rm2-(rm1-rm2)**2)*

     &    sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

          IF(kflr.GT.0) THEN

            IF(i.EQ.4) wid2=wids(6,3)

            IF(i.EQ.5) wid2=wids(7,3)

            IF(i.EQ.6) wid2=wids(6,2)*wids(8,3)

            IF(i.EQ.9) wid2=wids(17,3)

          ELSE

            IF(i.EQ.4) wid2=wids(6,2)

            IF(i.EQ.5) wid2=wids(7,2)

            IF(i.EQ.6) wid2=wids(6,3)*wids(8,2)

            IF(i.EQ.9) wid2=wids(17,2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  330   CONTINUE


      ELSEIF(kfla.EQ.51.OR.kfla.EQ.52) THEN

C...Techni-pi0 and techni-pi+-:

        fac=(3d0/(32d0*paru(1)*parp(142)**2))*shr

        DO 340 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 340

          pm1=pmas(pycomp(kfdp(idc,1)),1)

          pm2=pmas(pycomp(kfdp(idc,2)),1)

          rm1=pm1**2/sh

          rm2=pm2**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 340

          wid2=1d0

C...pi_tech -> f + f'.

          fcof=1d0

          IF(iabs(kfdp(idc,1)).LT.10) fcof=3d0*radc

          wdtp(i)=fac*fcof*(pm1+pm2)**2*

     &    sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  340   CONTINUE


      ELSEIF(kfla.EQ.53) THEN

C...Techni-pi'0 not yet implemented.


      ELSEIF(kfla.EQ.54) THEN

C...Techni-rho0:

        alprht=2.91d0*(3d0/parp(144))

        fac=(alprht/12d0)*shr

        facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)

        sqmz=pmas(23,1)**2

        gmmz=pmas(23,1)*pmas(23,2)

        xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))

        bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

        bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)

        DO 350 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 350

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 350

          IF(i.EQ.1) THEN

C...rho_tech0 -> W+ + W-.

            wdtp(i)=fac*parp(141)**4*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(24,1)

          ELSEIF(i.EQ.2) THEN

C...rho_tech0 -> W+ + pi_tech-.

            wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(24,2)*wids(52,3)

          ELSEIF(i.EQ.3) THEN

C...rho_tech0 -> pi_tech+ + W-.

            wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(52,2)*wids(24,3)

          ELSEIF(i.EQ.4) THEN

C...rho_tech0 -> pi_tech+ + pi_tech-.

            wdtp(i)=fac*(1d0-parp(141)**2)**2*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(52,1)

          ELSE

C...rho_tech0 -> f + fbar.

            wid2=1d0

            IF(i.LE.12) THEN

              ia=i-4

              fcof=3d0*radc

              IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)

            ELSE

              ia=i-2

              fcof=1d0

              IF(ia.GE.17) wid2=wids(ia,1)

            ENDIF

            ei=kchg(ia,1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=0.5d0*(vi+ai)

            vari=0.5d0*(vi-ai)

            wdtp(i)=facf*fcof*(1d0-rm1)*sqrt(max(0d0,1d0-4d0*rm1))*

     &      ((ei+vali*bwzr)**2+(vali*bwzi)**2+

     &      (ei+vari*bwzr)**2+(vari*bwzi)**2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  350   CONTINUE


      ELSEIF(kfla.EQ.55) THEN

C...Techni-rho+/-:

        alprht=2.91d0*(3d0/parp(144))

        fac=(alprht/12d0)*shr

        sqmw=pmas(24,1)**2

        gmmw=pmas(24,1)*pmas(24,2)

        facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)*

     &  (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)

        DO 360 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 360

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 360

          IF(i.EQ.1) THEN

C...rho_tech+ -> W+ + Z0.

            wdtp(i)=fac*parp(141)**4*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(kflr.GT.0) THEN

              wid2=wids(24,2)*wids(23,2)

            ELSE

              wid2=wids(24,3)*wids(23,2)

            ENDIF

          ELSEIF(i.EQ.2) THEN

C...rho_tech+ -> W+ + pi_tech0.

            wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(kflr.GT.0) THEN

              wid2=wids(24,2)*wids(51,2)

            ELSE

              wid2=wids(24,3)*wids(51,2)

            ENDIF

          ELSEIF(i.EQ.3) THEN

C...rho_tech+ -> pi_tech+ + Z0.

            wdtp(i)=fac*parp(141)**2*(1d0-parp(141)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(kflr.GT.0) THEN

              wid2=wids(52,2)*wids(23,2)

            ELSE

              wid2=wids(52,3)*wids(23,2)

            ENDIF

          ELSEIF(i.EQ.4) THEN

C...rho_tech+ -> pi_tech+ + pi_tech0.

            wdtp(i)=fac*(1d0-parp(141)**2)**2*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            IF(kflr.GT.0) THEN

              wid2=wids(52,2)*wids(51,2)

            ELSE

              wid2=wids(52,3)*wids(51,2)

            ENDIF

          ELSE

C...rho_tech+ -> f + fbar'.

            ia=i-4

            wid2=1d0

            IF(ia.LE.16) THEN

              fcof=3d0*radc*vckm((ia-1)/4+1,mod(ia-1,4)+1)

              IF(kflr.GT.0) THEN

                IF(mod(ia,4).EQ.3) wid2=wids(6,2)

                IF(mod(ia,4).EQ.0) wid2=wids(8,2)

                IF(ia.GE.13) wid2=wid2*wids(7,3)

              ELSE

                IF(mod(ia,4).EQ.3) wid2=wids(6,3)

                IF(mod(ia,4).EQ.0) wid2=wids(8,3)

                IF(ia.GE.13) wid2=wid2*wids(7,2)

              ENDIF

            ELSE

              fcof=1d0

              IF(kflr.GT.0) THEN

                IF(ia.EQ.20) wid2=wids(17,3)*wids(18,2)

              ELSE

                IF(ia.EQ.20) wid2=wids(17,2)*wids(18,3)

              ENDIF

            ENDIF

            wdtp(i)=facf*fcof*0.5d0*(2d0-rm1-rm2-(rm1-rm2)**2)*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  360   CONTINUE


      ELSEIF(kfla.EQ.56) THEN

C...Techni-omega:

        alprht=2.91d0*(3d0/parp(144))

        fac=(aem/24d0)*(shr**3/parp(145)**2)

        facf=(1d0/6d0)*(aem**2/alprht)*(pmas(kfla,1)**4/shr**3)*

     &  (2d0*parp(143)-1d0)**2

        sqmz=pmas(23,1)**2

        gmmz=pmas(23,1)*pmas(23,2)

        bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

        bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)

        DO 370 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 370

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 370

          IF(i.EQ.1) THEN

C...omega_tech0 -> gamma + pi_tech0.

            wdtp(i)=fac*

     &      sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))**3

            wid2=wids(51,2)

          ELSEIF(i.EQ.2) THEN

C...omega_tech0 -> Z0 + pi_tech0 not known.

            wdtp(i)=0d0

            wid2=wids(23,2)*wids(51,2)

          ELSE

C...omega_tech0 -> f + fbar.

            wid2=1d0

            IF(i.LE.10) THEN

              ia=i-2

              fcof=3d0*radc

              IF(ia.GE.6.AND.ia.LE.8) wid2=wids(ia,1)

            ELSE

              ia=i

              fcof=1d0

              IF(ia.GE.17) wid2=wids(ia,1)

            ENDIF

            ei=kchg(ia,1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=0.5d0*(vi+ai)

            vari=0.5d0*(vi-ai)

            wdtp(i)=facf*fcof*(1d0-rm1)*sqrt(max(0d0,1d0-4d0*rm1))*

     &      ((ei-vali*bwzr)**2+(vali*bwzi)**2+

     &      (ei-vari*bwzr)**2+(vari*bwzi)**2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  370   CONTINUE


      ELSEIF(kfla.EQ.kexcit+1) THEN

C...d* excited quark.

        fac=(sh/paru(155)**2)*shr

        DO 380 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 380

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 380

          IF(i.EQ.1) THEN

C...d* -> g + d.

            wdtp(i)=fac*as*paru(159)**2/3d0

            wid2=1d0

          ELSEIF(i.EQ.2) THEN

C...d* -> gamma + d.

            qf=-paru(157)/2d0+paru(158)/6d0

            wdtp(i)=fac*aem*qf**2/4d0

            wid2=1d0

          ELSEIF(i.EQ.3) THEN

C...d* -> Z0 + d.

            qf=-paru(157)*xw1/2d0-paru(158)*xw/6d0

            wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*

     &      (1d0-rm1)**2*(2d0+rm1)

            wid2=wids(23,2)

          ELSEIF(i.EQ.4) THEN

C...d* -> W- + u.

            wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*

     &      (1d0-rm1)**2*(2d0+rm1)

            IF(kflr.GT.0) wid2=wids(24,3)

            IF(kflr.LT.0) wid2=wids(24,2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  380   CONTINUE


      ELSEIF(kfla.EQ.kexcit+2) THEN

C...u* excited quark.

        fac=(sh/paru(155)**2)*shr

        DO 390 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 390

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 390

          IF(i.EQ.1) THEN

C...u* -> g + u.

            wdtp(i)=fac*as*paru(159)**2/3d0

            wid2=1d0

          ELSEIF(i.EQ.2) THEN

C...u* -> gamma + u.

            qf=paru(157)/2d0+paru(158)/6d0

            wdtp(i)=fac*aem*qf**2/4d0

            wid2=1d0

          ELSEIF(i.EQ.3) THEN

C...u* -> Z0 + u.

            qf=paru(157)*xw1/2d0-paru(158)*xw/6d0

            wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*

     &      (1d0-rm1)**2*(2d0+rm1)

            wid2=wids(23,2)

          ELSEIF(i.EQ.4) THEN

C...u* -> W+ + d.

            wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*

     &      (1d0-rm1)**2*(2d0+rm1)

            IF(kflr.GT.0) wid2=wids(24,2)

            IF(kflr.LT.0) wid2=wids(24,3)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  390   CONTINUE


      ELSEIF(kfla.EQ.kexcit+11) THEN

C...e* excited lepton.

        fac=(sh/paru(155)**2)*shr

        DO 400 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 400

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 400

          IF(i.EQ.1) THEN

C...e* -> gamma + e.

            qf=-paru(157)/2d0-paru(158)/2d0

            wdtp(i)=fac*aem*qf**2/4d0

            wid2=1d0

          ELSEIF(i.EQ.2) THEN

C...e* -> Z0 + e.

            qf=-paru(157)*xw1/2d0+paru(158)*xw/2d0

            wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*

     &      (1d0-rm1)**2*(2d0+rm1)

            wid2=wids(23,2)

          ELSEIF(i.EQ.3) THEN

C...e* -> W- + nu.

            wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*

     &      (1d0-rm1)**2*(2d0+rm1)

            IF(kflr.GT.0) wid2=wids(24,3)

            IF(kflr.LT.0) wid2=wids(24,2)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  400   CONTINUE


      ELSEIF(kfla.EQ.kexcit+12) THEN

C...nu*_e excited neutrino.

        fac=(sh/paru(155)**2)*shr

        DO 410 i=1,mdcy(kc,3)

          idc=i+mdcy(kc,2)-1

          IF(mdme(idc,1).LT.0) goto 410

          rm1=pmas(pycomp(kfdp(idc,1)),1)**2/sh

          rm2=pmas(pycomp(kfdp(idc,2)),1)**2/sh

          IF(sqrt(rm1)+sqrt(rm2).GT.1d0) goto 410

          IF(i.EQ.1) THEN

C...nu*_e -> Z0 + nu*_e.

            qf=paru(157)*xw1/2d0+paru(158)*xw/2d0

            wdtp(i)=fac*aem*qf**2/(8d0*xw*xw1)*

     &      (1d0-rm1)**2*(2d0+rm1)

            wid2=wids(23,2)

          ELSEIF(i.EQ.2) THEN

C...nu*_e -> W+ + e.

            wdtp(i)=fac*aem*paru(157)**2/(16d0*xw)*

     &      (1d0-rm1)**2*(2d0+rm1)

            IF(kflr.GT.0) wid2=wids(24,2)

            IF(kflr.LT.0) wid2=wids(24,3)

          ENDIF

          wdtp(0)=wdtp(0)+wdtp(i)

          IF(mdme(idc,1).GT.0) THEN

            wdte(i,mdme(idc,1))=wdtp(i)*wid2

            wdte(0,mdme(idc,1))=wdte(0,mdme(idc,1))+wdte(i,mdme(idc,1))

            wdte(i,0)=wdte(i,mdme(idc,1))

            wdte(0,0)=wdte(0,0)+wdte(i,0)

          ENDIF

  410   CONTINUE


      ENDIF

      mint(61)=0

      mint(62)=0

      mint(63)=0


      RETURN

      END


C***********************************************************************


C...PYOFSH

C...Calculates partial width and differential cross-section maxima

C...of channels/processes not allowed on mass-shell, and selects

C...masses in such channels/processes.


      SUBROUTINE pyofsh(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,/pyint1/,

     &/pyint2/,/pyint5/

C...Local arrays.

      dimension kfd(2),mbw(2),pmd(2),pgd(2),pmg(2),pml(2),pmu(2),

     &pmh(2),atl(2),atu(2),ath(2),rmg(2),inx1(100),xpt1(100),

     &fpt1(100),inx2(100),xpt2(100),fpt2(100),wdtp(0:200),

     &wdte(0:200,0:5)


C...Find if particles equal, maximum mass, matrix elements, etc.

      mint(51)=0

      isub=mint(1)

      kfd(1)=iabs(kfd1)

      kfd(2)=iabs(kfd2)

      meql=0

      IF(kfd(1).EQ.kfd(2)) meql=1

      mlm=0

      IF(mofsh.GE.2.AND.meql.EQ.1) mlm=int(1.5d0+pyr(0))

      IF(mofsh.LE.2.OR.mofsh.EQ.5) THEN

        noff=44

        pmmx=pmmo

      ELSE

        noff=40

        pmmx=vint(1)

        IF(ckin(2).GT.ckin(1)) pmmx=min(ckin(2),vint(1))

      ENDIF

      mmed=0

      IF((kfmo.EQ.25.OR.kfmo.EQ.35.OR.kfmo.EQ.36).AND.meql.EQ.1.AND.

     &(kfd(1).EQ.23.OR.kfd(1).EQ.24)) mmed=1

      IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(1).EQ.23.OR.

     &kfd(1).EQ.24).AND.(kfd(2).EQ.23.OR.kfd(2).EQ.24)) mmed=2

      IF((kfmo.EQ.32.OR.iabs(kfmo).EQ.34).AND.(kfd(2).EQ.25.OR.

     &kfd(2).EQ.35.OR.kfd(2).EQ.36)) mmed=3

      loop=1


C...Find where Breit-Wigners are required, else select discrete masses.

  100 DO 110 i=1,2

        kfca=pycomp(kfd(i))

        IF(kfca.GT.0) THEN

          pmd(i)=pmas(kfca,1)

          pgd(i)=pmas(kfca,2)

        ELSE

          pmd(i)=0d0

          pgd(i)=0d0

        ENDIF

        IF(mstp(42).LE.0.OR.pgd(i).LT.parp(41)) THEN

          mbw(i)=0

          pmg(i)=pmd(i)

          rmg(i)=(pmg(i)/pmmx)**2

        ELSE

          mbw(i)=1

        ENDIF

  110 CONTINUE


C...Find allowed mass range and Breit-Wigner parameters.

      DO 120 i=1,2

        IF(mofsh.EQ.1.AND.loop.EQ.1.AND.mbw(i).EQ.1) THEN

          pml(i)=parp(42)

          pmu(i)=pmmx-parp(42)

          IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))

          IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1

        ELSEIF(mbw(i).EQ.1.AND.mofsh.NE.5) THEN

          ilm=i

          IF(mlm.EQ.2) ilm=3-i

          pml(i)=max(ckin(noff+2*ilm-1),parp(42))

          pmu(i)=pmmx-max(ckin(noff+5-2*ilm),parp(42))

          IF(ckin(noff+2*ilm).GT.ckin(noff+2*ilm-1)) pmu(i)=min(pmu(i),

     &    ckin(noff+2*ilm))

          IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))

          IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)

          IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)

          IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1

          IF(mbw(i).EQ.1) THEN

            atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))

            atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))

            IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*

     &      pgd(i)))

          ENDIF

        ELSEIF(mbw(i).EQ.1.AND.mofsh.EQ.5) THEN

          ilm=i

          IF(mlm.EQ.2) ilm=3-i

          pml(i)=max(ckin(48+i),parp(42))

          pmu(i)=pmmx-max(ckin(51-i),parp(42))

          IF(mbw(3-i).EQ.0) pmu(i)=min(pmu(i),pmmx-pmd(3-i))

          IF(i.EQ.mlm) pmu(i)=min(pmu(i),0.5d0*pmmx)

          IF(meql.EQ.0) pmh(i)=min(pmu(i),0.5d0*pmmx)

          IF(pmu(i).LT.pml(i)+parj(64)) mbw(i)=-1

          IF(mbw(i).EQ.1) THEN

            atl(i)=atan((pml(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))

            atu(i)=atan((pmu(i)**2-pmd(i)**2)/(pmd(i)*pgd(i)))

            IF(meql.EQ.0) ath(i)=atan((pmh(i)**2-pmd(i)**2)/(pmd(i)*

     &      pgd(i)))

          ENDIF

        ENDIF

  120 CONTINUE

      IF(mbw(1).LT.0.OR.mbw(2).LT.0.OR.(mbw(1).EQ.0.AND.mbw(2).EQ.0))

     &THEN

        CALL pyerrm(3,'(PYOFSH:) no allowed decay product masses')

        mint(51)=1

        RETURN

      ENDIF


C...Calculation of partial width of resonance.

      IF(mofsh.EQ.1) THEN


C..If only one integration, pick that to be the inner.

        IF(mbw(1).EQ.0) THEN

          pm2=pmd(1)

          pmd(1)=pmd(2)

          pgd(1)=pgd(2)

          pml(1)=pml(2)

          pmu(1)=pmu(2)

        ELSEIF(mbw(2).EQ.0) THEN

          pm2=pmd(2)

        ENDIF


C...Start outer loop of integration.

        IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN

          atl2=atan((pml(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))

          atu2=atan((pmu(2)**2-pmd(2)**2)/(pmd(2)*pgd(2)))

          npt2=1

          xpt2(1)=1d0

          inx2(1)=0

          fmax2=0d0

        ENDIF

  130   IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN

          pm2s=pmd(2)**2+pmd(2)*pgd(2)*tan(atl2+xpt2(npt2)*(atu2-atl2))

          pm2=min(pmu(2),max(pml(2),sqrt(max(0d0,pm2s))))

        ENDIF

        rm2=(pm2/pmmx)**2


C...Start inner loop of integration.

        pml1=pml(1)

        pmu1=min(pmu(1),pmmx-pm2)

        IF(meql.EQ.1) pmu1=min(pmu1,pm2)

        atl1=atan((pml1**2-pmd(1)**2)/(pmd(1)*pgd(1)))

        atu1=atan((pmu1**2-pmd(1)**2)/(pmd(1)*pgd(1)))

        IF(pml1+parj(64).GE.pmu1.OR.atl1+1d-7.GE.atu1) THEN

          func2=0d0

          goto 180

        ENDIF

        npt1=1

        xpt1(1)=1d0

        inx1(1)=0

        fmax1=0d0

  140   pm1s=pmd(1)**2+pmd(1)*pgd(1)*tan(atl1+xpt1(npt1)*(atu1-atl1))

        pm1=min(pmu1,max(pml1,sqrt(max(0d0,pm1s))))

        rm1=(pm1/pmmx)**2


C...Evaluate function value - inner loop.

        func1=sqrt(max(0d0,(1d0-rm1-rm2)**2-4d0*rm1*rm2))

        IF(mmed.EQ.1) func1=func1*((1d0-rm1-rm2)**2+8d0*rm1*rm2)

        IF(mmed.EQ.2) func1=func1**3*(1d0+10d0*rm1+10d0*rm2+rm1**2+

     &  rm2**2+10d0*rm1*rm2)

        IF(func1.GT.fmax1) fmax1=func1

        fpt1(npt1)=func1


C...Go to next position in inner loop.

        IF(npt1.EQ.1) THEN

          npt1=npt1+1

          xpt1(npt1)=0d0

          inx1(npt1)=1

          goto 140

        ELSEIF(npt1.LE.8) THEN

          npt1=npt1+1

          IF(npt1.LE.4.OR.npt1.EQ.6) ish1=1

          ish1=ish1+1

          xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))

          inx1(npt1)=inx1(ish1)

          inx1(ish1)=npt1

          goto 140

        ELSEIF(npt1.LT.100) THEN

          isn1=ish1

  150     ish1=ish1+1

          IF(ish1.GT.npt1) ish1=2

          IF(ish1.EQ.isn1) goto 160

          dfpt1=abs(fpt1(ish1)-fpt1(inx1(ish1)))

          IF(dfpt1.LT.parp(43)*fmax1) goto 150

          npt1=npt1+1

          xpt1(npt1)=0.5d0*(xpt1(ish1)+xpt1(inx1(ish1)))

          inx1(npt1)=inx1(ish1)

          inx1(ish1)=npt1

          goto 140

        ENDIF


C...Calculate integral over inner loop.

  160   fsum1=0d0

        DO 170 ipt1=2,npt1

          fsum1=fsum1+0.5d0*(fpt1(ipt1)+fpt1(inx1(ipt1)))*

     &    (xpt1(inx1(ipt1))-xpt1(ipt1))

  170   CONTINUE

        func2=fsum1*(atu1-atl1)/paru(1)

  180   IF(mbw(1).EQ.1.AND.mbw(2).EQ.1) THEN

          IF(func2.GT.fmax2) fmax2=func2

          fpt2(npt2)=func2


C...Go to next position in outer loop.

          IF(npt2.EQ.1) THEN

            npt2=npt2+1

            xpt2(npt2)=0d0

            inx2(npt2)=1

            goto 130

          ELSEIF(npt2.LE.8) THEN

            npt2=npt2+1

            IF(npt2.LE.4.OR.npt2.EQ.6) ish2=1

            ish2=ish2+1

            xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))

            inx2(npt2)=inx2(ish2)

            inx2(ish2)=npt2

            goto 130

          ELSEIF(npt2.LT.100) THEN

            isn2=ish2

  190       ish2=ish2+1

            IF(ish2.GT.npt2) ish2=2

            IF(ish2.EQ.isn2) goto 200

            dfpt2=abs(fpt2(ish2)-fpt2(inx2(ish2)))

            IF(dfpt2.LT.parp(43)*fmax2) goto 190

            npt2=npt2+1

            xpt2(npt2)=0.5d0*(xpt2(ish2)+xpt2(inx2(ish2)))

            inx2(npt2)=inx2(ish2)

            inx2(ish2)=npt2

            goto 130

          ENDIF


C...Calculate integral over outer loop.

  200     fsum2=0d0

          DO 210 ipt2=2,npt2

            fsum2=fsum2+0.5d0*(fpt2(ipt2)+fpt2(inx2(ipt2)))*

     &      (xpt2(inx2(ipt2))-xpt2(ipt2))

  210     CONTINUE

          fsum2=fsum2*(atu2-atl2)/paru(1)

          IF(meql.EQ.1) fsum2=2d0*fsum2

        ELSE

          fsum2=func2

        ENDIF


C...Save result; second integration for user-selected mass range.

        IF(loop.EQ.1) widw=fsum2

        wid2=fsum2

        IF(loop.EQ.1.AND.(ckin(46).GE.ckin(45).OR.ckin(48).GE.ckin(47)

     &  .OR.max(ckin(45),ckin(47)).GE.1.01d0*parp(42))) THEN

          loop=2

          goto 100

        ENDIF

        ret1=widw

        ret2=wid2/widw


C...Select two decay product masses of a resonance.

      ELSEIF(mofsh.EQ.2.OR.mofsh.EQ.5) THEN

  220   DO 230 i=1,2

          IF(mbw(i).EQ.0) goto 230

          pmbw=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*

     &    (atu(i)-atl(i)))

          pmg(i)=min(pmu(i),max(pml(i),sqrt(max(0d0,pmbw))))

          rmg(i)=(pmg(i)/pmmx)**2

  230   CONTINUE

        IF((meql.EQ.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.

     &  pmg(1)+pmg(2)+parj(64).GT.pmmx) goto 220


C...Weight with matrix element (if none known, use beta factor).

        flam=sqrt(max(0d0,(1d0-rmg(1)-rmg(2))**2-4d0*rmg(1)*rmg(2)))

        IF(mmed.EQ.1) THEN

          wtbe=flam*((1d0-rmg(1)-rmg(2))**2+8d0*rmg(1)*rmg(2))

        ELSEIF(mmed.EQ.2) THEN

          wtbe=flam**3*(1d0+10d0*rmg(1)+10d0*rmg(2)+rmg(1)**2+

     &    rmg(2)**2+10d0*rmg(1)*rmg(2))

        ELSEIF(mmed.EQ.3) THEN

          wtbe=flam*(rmg(1)+flam**2/12d0)

        ELSE

          wtbe=flam

        ENDIF

        IF(wtbe.LT.pyr(0)) goto 220

        ret1=pmg(1)

        ret2=pmg(2)


C...Find suitable set of masses for initialization of 2 -> 2 processes.

      ELSEIF(mofsh.EQ.3) THEN

        IF(mbw(1).NE.0.AND.mbw(2).EQ.0) THEN

          pmg(1)=min(pmd(1),0.5d0*(pml(1)+pmu(1)))

          pmg(2)=pmd(2)

        ELSEIF(mbw(2).NE.0.AND.mbw(1).EQ.0) THEN

          pmg(1)=pmd(1)

          pmg(2)=min(pmd(2),0.5d0*(pml(2)+pmu(2)))

        ELSE

          idiv=-1

  240     idiv=idiv+1

          pmg(1)=min(pmd(1),0.1d0*(idiv*pml(1)+(10-idiv)*pmu(1)))

          pmg(2)=min(pmd(2),0.1d0*(idiv*pml(2)+(10-idiv)*pmu(2)))

          IF(idiv.LE.9.AND.pmg(1)+pmg(2).GT.0.9d0*pmmx) goto 240

        ENDIF

        ret1=pmg(1)

        ret2=pmg(2)


C...Evaluate importance of excluded tails of Breit-Wigners.

        IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)

     &  .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2

        IF(meql.LE.1) THEN

          vint(80)=1d0

          DO 250 i=1,2

            IF(mbw(i).NE.0) vint(80)=vint(80)*1.25d0*(atu(i)-atl(i))/

     &      paru(1)

  250     CONTINUE

        ELSE

          vint(80)=(1.25d0/paru(1))**2*max((atu(1)-atl(1))*

     &    (ath(2)-atl(2)),(ath(1)-atl(1))*(atu(2)-atl(2)))

        ENDIF

        IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.30.OR.isub.EQ.35).AND.

     &  mstp(43).NE.2) vint(80)=2d0*vint(80)

        IF(isub.EQ.22.AND.mstp(43).NE.2) vint(80)=4d0*vint(80)

        IF(meql.GE.1) vint(80)=2d0*vint(80)


C...Pick one particle to be the lighter (if improves efficiency).

      ELSEIF(mofsh.EQ.4) THEN

        IF(meql.EQ.0.AND.mbw(1).EQ.1.AND.mbw(2).EQ.1.AND.pmd(1)+pmd(2)

     &  .GT.pmmx.AND.pmh(1).GT.pml(1).AND.pmh(2).GT.pml(2)) meql=2

  260   IF(meql.EQ.2) mlm=int(1.5d0+pyr(0))


C...Select two masses according to Breit-Wigner + flat in s + 1/s.

        DO 270 i=1,2

          IF(mbw(i).EQ.0) goto 270

          pmv=pmu(i)

          IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)

          atv=atu(i)

          IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)

          rbr=pyr(0)

          IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.

     &    isub.EQ.35).AND.mstp(43).NE.2) rbr=2d0*rbr

          IF(rbr.LT.0.8d0) THEN

            pmsr=pmd(i)**2+pmd(i)*pgd(i)*tan(atl(i)+pyr(0)*(atv-atl(i)))

            pmg(i)=min(pmv,max(pml(i),sqrt(max(0d0,pmsr))))

          ELSEIF(rbr.LT.0.9d0) THEN

            pmg(i)=sqrt(max(0d0,pml(i)**2+pyr(0)*(pmv**2-pml(i)**2)))

          ELSEIF(rbr.LT.1.5d0) THEN

            pmg(i)=pml(i)*(pmv/pml(i))**pyr(0)

          ELSE

            pmg(i)=sqrt(max(0d0,pml(i)**2*pmv**2/(pml(i)**2+pyr(0)*

     &      (pmv**2-pml(i)**2))))

          ENDIF

  270   CONTINUE

        IF((meql.GE.1.AND.pmg(max(1,mlm)).GT.pmg(min(2,3-mlm))).OR.

     &  pmg(1)+pmg(2)+parj(64).GT.pmmx) THEN

          IF(mint(48).EQ.1) THEN

            ngen(0,1)=ngen(0,1)+1

            ngen(mint(1),1)=ngen(mint(1),1)+1

            goto 260

          ELSE

            mint(51)=1

            RETURN

          ENDIF

        ENDIF

        ret1=pmg(1)

        ret2=pmg(2)


C...Give weight for selected mass distribution.

        vint(80)=1d0

        DO 280 i=1,2

          IF(mbw(i).EQ.0) goto 280

          pmv=pmu(i)

          IF(meql.EQ.2.AND.i.EQ.mlm) pmv=pmh(i)

          atv=atu(i)

          IF(meql.EQ.2.AND.i.EQ.mlm) atv=ath(i)

          f0=pmd(i)*pgd(i)/((pmg(i)**2-pmd(i)**2)**2+

     &    (pmd(i)*pgd(i))**2)/paru(1)

          f1=1d0

          f2=1d0/pmg(i)**2

          f3=1d0/pmg(i)**4

          fi0=(atv-atl(i))/paru(1)

          fi1=pmv**2-pml(i)**2

          fi2=2d0*log(pmv/pml(i))

          fi3=1d0/pml(i)**2-1d0/pmv**2

          IF((isub.EQ.15.OR.isub.EQ.19.OR.isub.EQ.22.OR.isub.EQ.30.OR.

     &    isub.EQ.35).AND.mstp(43).NE.2) THEN

            vint(80)=vint(80)*20d0/(8d0+(fi0/f0)*(f1/fi1+6d0*f2/fi2+

     &      5d0*f3/fi3))

          ELSE

            vint(80)=vint(80)*10d0/(8d0+(fi0/f0)*(f1/fi1+f2/fi2))

          ENDIF

          vint(80)=vint(80)*fi0

  280   CONTINUE

        IF(meql.GE.1) vint(80)=2d0*vint(80)

      ENDIF


      RETURN

      END


C***********************************************************************


C...PYRECO

C...Handles the possibility of colour reconnection in W+W- events,

C...Based on the main scenarios of the Sjostrand and Khoze study:

C...I, II, II', intermediate and instantaneous; plus one model

C...along the lines of the Gustafson and Hakkinen: GH.


      SUBROUTINE pyreco(IW1,IW2,NSD1,NAFT1)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter value; number of points in MC integration.

      parameter(npt=100)

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pypars/,/pyint1/

C...Local arrays.

      dimension nbeg(2),nend(2),inp(50),inm(50),beww(3),xp(3),xm(3),

     &v1(3),v2(3),betp(50,4),dirp(50,3),betm(50,4),dirm(50,3),

     &xd(4),xb(4),iap(npt),iam(npt),wta(npt),v1p(3),v2p(3),v1m(3),

     &v2m(3),q(4,3),xpp(3),xmm(3),ipc(20),imc(20),tc(0:20),tpc(20),

     &tmc(20),ijoin(100)


C...Functions to give four-product and to do determinants.

      four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)

      deter(i,j,l)=q(i,1)*q(j,2)*q(l,3)-q(i,1)*q(l,2)*q(j,3)+

     &q(j,1)*q(l,2)*q(i,3)-q(j,1)*q(i,2)*q(l,3)+

     &q(l,1)*q(i,2)*q(j,3)-q(l,1)*q(j,2)*q(i,3)


C...Only allow fraction of recoupling for GH, intermediate and

C...instantaneous.

      IF(mstp(115).EQ.5.OR.mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN

        IF(pyr(0).GT.parp(120)) RETURN

      ENDIF


C...Common part for scenarios I, II, II', and GH.

      IF(mstp(115).EQ.1.OR.mstp(115).EQ.2.OR.mstp(115).EQ.3.OR.

     &mstp(115).EQ.5) THEN


C...Read out frequently-used parameters.

        pi=paru(1)

        hbar=paru(3)

        pmw=pmas(24,1)

        pgw=pmas(24,2)

        tfrag=parp(115)

        rhad=parp(116)

        fact=parp(117)

        blowr=parp(118)

        blowt=parp(119)


C...Find range of decay products of the W's.

C...Background: the W's are stored in IW1 and IW2.

C...Their direct decay products in NSD1+1 through NSD1+4.

C...Products after shower (if any) in NSD1+5 through NAFT1

C...for first W and in NAFT1+1 through N for the second.

        IF(k(iw1,2).GT.0) THEN

          jt=1

        ELSE

          jt=2

        ENDIF

        jr=3-jt

        IF(naft1.GT.nsd1+4) THEN

          nbeg(jt)=nsd1+5

          nend(jt)=naft1

        ELSE

          nbeg(jt)=nsd1+1

          nend(jt)=nsd1+2

        ENDIF

        IF(n.GT.naft1) THEN

          nbeg(jr)=naft1+1

          nend(jr)=n

        ELSE

          nbeg(jr)=nsd1+3

          nend(jr)=nsd1+4

        ENDIF


C...Rearrange parton shower products along strings.

        nold=n

        CALL pyprep(nsd1+1)


C...Find partons pointing back to W+ and W-; store them with quark

C...end of string first.

        nnp=0

        nnm=0

        isgp=0

        isgm=0

        DO 120 i=nold+1,n

          IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 120

          IF(iabs(k(i,2)).GE.22) goto 120

          IF(k(i,3).GE.nbeg(1).AND.k(i,3).LE.nend(1)) THEN

            IF(isgp.EQ.0) isgp=isign(1,k(i,2))

            nnp=nnp+1

            IF(isgp.EQ.1) THEN

              inp(nnp)=i

            ELSE

              DO 100 i1=nnp,2,-1

                inp(i1)=inp(i1-1)

  100         CONTINUE

              inp(1)=i

            ENDIF

            IF(k(i,1).EQ.1) isgp=0

          ELSEIF(k(i,3).GE.nbeg(2).AND.k(i,3).LE.nend(2)) THEN

            IF(isgm.EQ.0) isgm=isign(1,k(i,2))

            nnm=nnm+1

            IF(isgm.EQ.1) THEN

              inm(nnm)=i

            ELSE

              DO 110 i1=nnm,2,-1

                inm(i1)=inm(i1-1)

  110         CONTINUE

              inm(1)=i

            ENDIF

            IF(k(i,1).EQ.1) isgm=0

          ENDIF

  120   CONTINUE


C...Boost to W+W- rest frame (not strictly needed).

        DO 130 j=1,3

          beww(j)=(p(iw1,j)+p(iw2,j))/(p(iw1,4)+p(iw2,4))

  130   CONTINUE

        CALL pyrobo(iw1,iw1,0d0,0d0,-beww(1),-beww(2),-beww(3))

        CALL pyrobo(iw2,iw2,0d0,0d0,-beww(1),-beww(2),-beww(3))

        CALL pyrobo(nold+1,n,0d0,0d0,-beww(1),-beww(2),-beww(3))


C...Select decay vertices of W+ and W-.

        tp=hbar*(-log(pyr(0)))*p(iw1,4)/

     &  sqrt((p(iw1,5)**2-pmw**2)**2+(p(iw1,5)**2*pgw/pmw)**2)

        tm=hbar*(-log(pyr(0)))*p(iw2,4)/

     &  sqrt((p(iw2,5)**2-pmw**2)**2+(p(iw2,5)**2*pgw/pmw)**2)

        gtmax=max(tp,tm)

        DO 140 j=1,3

          xp(j)=tp*p(iw1,j)/p(iw1,4)

          xm(j)=tm*p(iw2,j)/p(iw2,4)

  140   CONTINUE


C...Begin scenario I specifics.

        IF(mstp(115).EQ.1) THEN


C...Reconstruct velocity and direction of W+ string pieces.

          DO 170 iip=1,nnp-1

            IF(k(inp(iip),2).LT.0) goto 170

            i1=inp(iip)

            i2=inp(iip+1)

            p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)

            p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)

            DO 150 j=1,3

              v1(j)=p(i1,j)/p1a

              v2(j)=p(i2,j)/p2a

              betp(iip,j)=0.5d0*(v1(j)+v2(j))

              dirp(iip,j)=v1(j)-v2(j)

  150       CONTINUE

            betp(iip,4)=1d0/sqrt(1d0-betp(iip,1)**2-betp(iip,2)**2-

     &      betp(iip,3)**2)

            dirl=sqrt(dirp(iip,1)**2+dirp(iip,2)**2+dirp(iip,3)**2)

            DO 160 j=1,3

              dirp(iip,j)=dirp(iip,j)/dirl

  160       CONTINUE

  170     CONTINUE


C...Reconstruct velocity and direction of W- string pieces.

          DO 200 iim=1,nnm-1

            IF(k(inm(iim),2).LT.0) goto 200

            i1=inm(iim)

            i2=inm(iim+1)

            p1a=sqrt(p(i1,1)**2+p(i1,2)**2+p(i1,3)**2)

            p2a=sqrt(p(i2,1)**2+p(i2,2)**2+p(i2,3)**2)

            DO 180 j=1,3

              v1(j)=p(i1,j)/p1a

              v2(j)=p(i2,j)/p2a

              betm(iim,j)=0.5d0*(v1(j)+v2(j))

              dirm(iim,j)=v1(j)-v2(j)

  180       CONTINUE

            betm(iim,4)=1d0/sqrt(1d0-betm(iim,1)**2-betm(iim,2)**2-

     &      betm(iim,3)**2)

            dirl=sqrt(dirm(iim,1)**2+dirm(iim,2)**2+dirm(iim,3)**2)

            DO 190 j=1,3

              dirm(iim,j)=dirm(iim,j)/dirl

  190       CONTINUE

  200     CONTINUE


C...Loop over number of space-time points.

          nacc=0

          sum=0d0

          DO 250 ipt=1,npt


C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).

            r=sqrt(-log(pyr(0)))

            phi=2d0*pi*pyr(0)

            x=blowr*rhad*r*cos(phi)

            y=blowr*rhad*r*sin(phi)

            r=sqrt(-log(pyr(0)))

            phi=2d0*pi*pyr(0)

            z=blowr*rhad*r*cos(phi)

            t=gtmax+blowt*sqrt(0.5d0)*tfrag*r*abs(sin(phi))


C...Weight for sample distribution.

            wtsmp=exp(-(x**2+y**2+z**2)/(blowr*rhad)**2)*

     &      exp(-2d0*(t-gtmax)**2/(blowt*tfrag)**2)


C...Loop over W+ string pieces and find one with largest weight.

            imaxp=0

            wtmaxp=1d-10

            xd(1)=x-xp(1)

            xd(2)=y-xp(2)

            xd(3)=z-xp(3)

            xd(4)=t-tp

            DO 220 iip=1,nnp-1

              IF(k(inp(iip),2).LT.0) goto 220

              bed=betp(iip,1)*xd(1)+betp(iip,2)*xd(2)+betp(iip,3)*xd(3)

              bedg=betp(iip,4)*(betp(iip,4)*bed/(1d0+betp(iip,4))-xd(4))

              DO 210 j=1,3

                xb(j)=xd(j)+bedg*betp(iip,j)

  210         CONTINUE

              xb(4)=betp(iip,4)*(xd(4)-bed)

              sr2=xb(1)**2+xb(2)**2+xb(3)**2

              sz2=(dirp(iip,1)*xb(1)+dirp(iip,2)*xb(2)+

     &        dirp(iip,3)*xb(3))**2

              wtp=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/

     &        tfrag**2)

              IF(xb(4)-sqrt(sr2).LT.0d0) wtp=0d0

              IF(wtp.GT.wtmaxp) THEN

                imaxp=iip

                wtmaxp=wtp

              ENDIF

  220       CONTINUE


C...Loop over W- string pieces and find one with largest weight.

            imaxm=0

            wtmaxm=1d-10

            xd(1)=x-xm(1)

            xd(2)=y-xm(2)

            xd(3)=z-xm(3)

            xd(4)=t-tm

            DO 240 iim=1,nnm-1

              IF(k(inm(iim),2).LT.0) goto 240

              bed=betm(iim,1)*xd(1)+betm(iim,2)*xd(2)+betm(iim,3)*xd(3)

              bedg=betm(iim,4)*(betm(iim,4)*bed/(1d0+betm(iim,4))-xd(4))

              DO 230 j=1,3

                xb(j)=xd(j)+bedg*betm(iim,j)

  230         CONTINUE

              xb(4)=betm(iim,4)*(xd(4)-bed)

              sr2=xb(1)**2+xb(2)**2+xb(3)**2

              sz2=(dirm(iim,1)*xb(1)+dirm(iim,2)*xb(2)+

     &        dirm(iim,3)*xb(3))**2

              wtm=exp(-(sr2-sz2)/(2d0*rhad**2))*exp(-(xb(4)**2-sz2)/

     &        tfrag**2)

              IF(xb(4)-sqrt(sr2).LT.0d0) wtm=0d0

              IF(wtm.GT.wtmaxm) THEN

                imaxm=iim

                wtmaxm=wtm

              ENDIF

  240       CONTINUE


C...Result of integration.

            wt=0d0

            IF(imaxp.NE.0.AND.imaxm.NE.0) THEN

              wt=wtmaxp*wtmaxm/wtsmp

              sum=sum+wt

              nacc=nacc+1

              iap(nacc)=imaxp

              iam(nacc)=imaxm

              wta(nacc)=wt

            ENDIF

  250     CONTINUE

          res=blowr**3*blowt*sum/npt


C...Decide whether to reconnect and, if so, where.

          iacc=0

          prec=1d0-exp(-fact*res)

          IF(prec.GT.pyr(0)) THEN

            rsum=pyr(0)*sum

            DO 260 ia=1,nacc

              iacc=ia

              rsum=rsum-wta(ia)

              IF(rsum.LE.0d0) goto 270

  260       CONTINUE

  270       iip=iap(iacc)

            iim=iam(iacc)

          ENDIF


C...Begin scenario II and II' specifics.

        ELSEIF(mstp(115).EQ.2.OR.mstp(115).EQ.3) THEN


C...Loop through all string pieces, one from W+ and one from W-.

          ncross=0

          tc(0)=0d0

          DO 340 iip=1,nnp-1

            IF(k(inp(iip),2).LT.0) goto 340

            i1p=inp(iip)

            i2p=inp(iip+1)

            DO 330 iim=1,nnm-1

              IF(k(inm(iim),2).LT.0) goto 330

              i1m=inm(iim)

              i2m=inm(iim+1)


C...Find endpoint velocity vectors.

              DO 280 j=1,3

                v1p(j)=p(i1p,j)/p(i1p,4)

                v2p(j)=p(i2p,j)/p(i2p,4)

                v1m(j)=p(i1m,j)/p(i1m,4)

                v2m(j)=p(i2m,j)/p(i2m,4)

  280         CONTINUE


C...Define q matrix and find t.

              DO 290 j=1,3

                q(1,j)=v2p(j)-v1p(j)

                q(2,j)=-(v2m(j)-v1m(j))

                q(3,j)=xp(j)-xm(j)-tp*v1p(j)+tm*v1m(j)

                q(4,j)=v1p(j)-v1m(j)

  290         CONTINUE

              t=-deter(1,2,3)/deter(1,2,4)


C...Find alpha and beta; i.e. coordinates of crossing point.

              s11=q(1,1)*(t-tp)

              s12=q(2,1)*(t-tm)

              s13=q(3,1)+q(4,1)*t

              s21=q(1,2)*(t-tp)

              s22=q(2,2)*(t-tm)

              s23=q(3,2)+q(4,2)*t

              den=s11*s22-s12*s21

              alp=(s12*s23-s22*s13)/den

              bet=(s21*s13-s11*s23)/den


C...Check if solution acceptable.

              iansw=1

              IF(t.LT.gtmax) iansw=0

              IF(alp.LT.0d0.OR.alp.GT.1d0) iansw=0

              IF(bet.LT.0d0.OR.bet.GT.1d0) iansw=0


C...Find point of crossing and check that not inconsistent.

              DO 300 j=1,3

                xpp(j)=xp(j)+(v1p(j)+alp*(v2p(j)-v1p(j)))*(t-tp)

                xmm(j)=xm(j)+(v1m(j)+bet*(v2m(j)-v1m(j)))*(t-tm)

  300         CONTINUE

              d2pm=(xpp(1)-xmm(1))**2+(xpp(2)-xmm(2))**2+

     &        (xpp(3)-xmm(3))**2

              d2p=xpp(1)**2+xpp(2)**2+xpp(3)**2

              d2m=xmm(1)**2+xmm(2)**2+xmm(3)**2

              IF(d2pm.GT.1d-4*(d2p+d2m)) iansw=-1


C...Find string eigentimes at crossing.

              IF(iansw.EQ.1) THEN

                taup=sqrt(max(0d0,(t-tp)**2-(xpp(1)-xp(1))**2-

     &          (xpp(2)-xp(2))**2-(xpp(3)-xp(3))**2))

                taum=sqrt(max(0d0,(t-tm)**2-(xmm(1)-xm(1))**2-

     &          (xmm(2)-xm(2))**2-(xmm(3)-xm(3))**2))

              ELSE

                taup=0d0

                taum=0d0

              ENDIF


C...Order crossings by time. End loop over crossings.

              IF(iansw.EQ.1.AND.ncross.LT.20) THEN

                ncross=ncross+1

                DO 310 i1=ncross,1,-1

                  IF(t.GT.tc(i1-1).OR.i1.EQ.1) THEN

                    ipc(i1)=iip

                    imc(i1)=iim

                    tc(i1)=t

                    tpc(i1)=taup

                    tmc(i1)=taum

                    goto 320

                  ELSE

                    ipc(i1)=ipc(i1-1)

                    imc(i1)=imc(i1-1)

                    tc(i1)=tc(i1-1)

                    tpc(i1)=tpc(i1-1)

                    tmc(i1)=tmc(i1-1)

                  ENDIF

  310           CONTINUE

  320           CONTINUE

              ENDIF

  330       CONTINUE

  340     CONTINUE


C...Loop over crossings; find first (if any) acceptable one.

          iacc=0

          IF(ncross.GE.1) THEN

            DO 350 ic=1,ncross

              pnfrag=exp(-(tpc(ic)**2+tmc(ic)**2)/tfrag**2)

              IF(pnfrag.GT.pyr(0)) THEN

C...Scenario II: only compare with fragmentation time.

                IF(mstp(115).EQ.2) THEN

                  iacc=ic

                  iip=ipc(iacc)

                  iim=imc(iacc)

                  goto 360

C...Scenario II': also require that string length decreases.

                ELSE

                  iip=ipc(ic)

                  iim=imc(ic)

                  i1p=inp(iip)

                  i2p=inp(iip+1)

                  i1m=inm(iim)

                  i2m=inm(iim+1)

                  elold=four(i1p,i2p)*four(i1m,i2m)

                  elnew=four(i1p,i2m)*four(i1m,i2p)

                  IF(elnew.LT.elold) THEN

                    iacc=ic

                    iip=ipc(iacc)

                    iim=imc(iacc)

                    goto 360

                  ENDIF

                ENDIF

              ENDIF

  350       CONTINUE

  360       CONTINUE

          ENDIF


C...Begin scenario GH specifics.

        ELSEIF(mstp(115).EQ.5) THEN


C...Loop through all string pieces, one from W+ and one from W-.

          iacc=0

          elmin=1d0

          DO 380 iip=1,nnp-1

            IF(k(inp(iip),2).LT.0) goto 380

            i1p=inp(iip)

            i2p=inp(iip+1)

            DO 370 iim=1,nnm-1

              IF(k(inm(iim),2).LT.0) goto 370

              i1m=inm(iim)

              i2m=inm(iim+1)


C...Look for largest decrease of (exponent of) Lambda measure.

              elold=four(i1p,i2p)*four(i1m,i2m)

              elnew=four(i1p,i2m)*four(i1m,i2p)

              eldif=elnew/max(1d-10,elold)

              IF(eldif.LT.elmin) THEN

                iacc=iip+iim

                elmin=eldif

                ipc(1)=iip

                imc(1)=iim

              ENDIF

  370       CONTINUE

  380     CONTINUE

          iip=ipc(1)

          iim=imc(1)

        ENDIF


C...Common for scenarios I, II, II' and GH: reconnect strings.

        IF(iacc.NE.0) THEN

          mint(32)=1

          njoin=0

          DO 390 is=1,nnp+nnm

            njoin=njoin+1

            IF(is.LE.iip) THEN

              i=inp(is)

            ELSEIF(is.LE.iip+nnm-iim) THEN

              i=inm(is-iip+iim)

            ELSEIF(is.LE.iip+nnm) THEN

              i=inm(is-iip-nnm+iim)

            ELSE

              i=inp(is-nnm)

            ENDIF

            ijoin(njoin)=i

            IF(k(i,2).LT.0) THEN

              CALL pyjoin(njoin,ijoin)

              njoin=0

            ENDIF

  390     CONTINUE


C...Restore original event record if no reconnection.

        ELSE

          DO 400 i=nsd1+1,nold

            IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) THEN

              k(i,4)=mod(k(i,4),mstu(5)**2)

              k(i,5)=mod(k(i,5),mstu(5)**2)

            ENDIF

  400     CONTINUE

          DO 410 i=nold+1,n

            k(k(i,3),1)=3

  410     CONTINUE

          n=nold

        ENDIF


C...Boost back system.

        CALL pyrobo(iw1,iw1,0d0,0d0,beww(1),beww(2),beww(3))

        CALL pyrobo(iw2,iw2,0d0,0d0,beww(1),beww(2),beww(3))

        IF(n.GT.nold) CALL pyrobo(nold+1,n,0d0,0d0,

     &  beww(1),beww(2),beww(3))


C...Common part for intermediate and instantaneous scenarios.

      ELSEIF(mstp(115).EQ.11.OR.mstp(115).EQ.12) THEN

        mint(32)=1


C...Remove old shower products and reset showering ones.

        n=nsd1+4

        DO 420 i=nsd1+1,nsd1+4

          k(i,1)=3

          k(i,4)=mod(k(i,4),mstu(5)**2)

          k(i,5)=mod(k(i,5),mstu(5)**2)

  420   CONTINUE


C...Identify quark-antiquark pairs.

        iq1=nsd1+1

        iq2=nsd1+2

        iq3=nsd1+3

        IF(k(iq1,2)*k(iq3,2).LT.0) iq3=nsd1+4

        iq4=2*nsd1+7-iq3


C...Reconnect strings.

        ijoin(1)=iq1

        ijoin(2)=iq4

        CALL pyjoin(2,ijoin)

        ijoin(1)=iq3

        ijoin(2)=iq2

        CALL pyjoin(2,ijoin)


C...Do new parton showers in intermediate scenario.

        IF(mstp(71).GE.1.AND.mstp(115).EQ.11) THEN

          CALL pyshow(iq1,iq2,p(iw1,5))

          CALL pyshow(iq3,iq4,p(iw2,5))


C...Do new parton showers in instantaneous scenario.

        ELSEIF(mstp(71).GE.1.AND.mstp(115).EQ.12) THEN

          ppm2=(p(iq1,4)+p(iq4,4))**2-(p(iq1,1)+p(iq4,1))**2-

     &    (p(iq1,2)+p(iq4,2))**2-(p(iq1,3)+p(iq4,3))**2

          ppm=sqrt(max(0d0,ppm2))

          CALL pyshow(iq1,iq4,ppm)

          ppm2=(p(iq3,4)+p(iq2,4))**2-(p(iq3,1)+p(iq2,1))**2-

     &    (p(iq3,2)+p(iq2,2))**2-(p(iq3,3)+p(iq2,3))**2

          ppm=sqrt(max(0d0,ppm2))

          CALL pyshow(iq3,iq2,ppm)

        ENDIF

      ENDIF


      RETURN

      END


C***********************************************************************


C...PYKLIM

C...Checks generated variables against pre-set kinematical limits;

C...also calculates limits on variables used in generation.


      SUBROUTINE pyklim(ILIM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/


C...Common kinematical expressions.

      mint(51)=0

      isub=mint(1)

      istsb=iset(isub)

      IF(isub.EQ.96) goto 100

      sqm3=vint(63)

      sqm4=vint(64)

      IF(ilim.NE.0) THEN

        IF(abs(sqm3).LT.1d-4.AND.abs(sqm4).LT.1d-4) THEN

          ckin09=max(ckin(9),ckin(13))

          ckin10=min(ckin(10),ckin(14))

          ckin11=max(ckin(11),ckin(15))

          ckin12=min(ckin(12),ckin(16))

        ELSE

          ckin09=max(ckin(9),min(0d0,ckin(13)))

          ckin10=min(ckin(10),max(0d0,ckin(14)))

          ckin11=max(ckin(11),min(0d0,ckin(15)))

          ckin12=min(ckin(12),max(0d0,ckin(16)))

        ENDIF

      ENDIF

      IF(ilim.NE.1) THEN

        tau=vint(21)

        rm3=sqm3/(tau*vint(2))

        rm4=sqm4/(tau*vint(2))

        be34=sqrt(max(1d-20,(1d0-rm3-rm4)**2-4d0*rm3*rm4))

      ENDIF

      pthmin=ckin(3)

      IF(min(sqm3,sqm4).LT.ckin(6)**2.AND.istsb.NE.1.AND.istsb.NE.3)

     &pthmin=max(ckin(3),ckin(5))


      IF(ilim.EQ.0) THEN

C...Check generated values of tau, y*, cos(theta-hat), and tau' against

C...pre-set kinematical limits.

        yst=vint(22)

        cth=vint(23)

        taup=vint(26)

        taue=tau

        IF(istsb.GE.3.AND.istsb.LE.5) taue=taup

        x1=sqrt(taue)*exp(yst)

        x2=sqrt(taue)*exp(-yst)

        xf=x1-x2

        IF(mint(47).NE.1) THEN

          IF(tau*vint(2).LT.ckin(1)**2) mint(51)=1

          IF(ckin(2).GE.0d0.AND.tau*vint(2).GT.ckin(2)**2) mint(51)=1

          IF(yst.LT.ckin(7).OR.yst.GT.ckin(8)) mint(51)=1

          IF(xf.LT.ckin(25).OR.xf.GT.ckin(26)) mint(51)=1

        ENDIF

        IF(mint(45).NE.1) THEN

          IF(x1.LT.ckin(21).OR.x1.GT.ckin(22)) mint(51)=1

        ENDIF

        IF(mint(46).NE.1) THEN

          IF(x2.LT.ckin(23).OR.x2.GT.ckin(24)) mint(51)=1

        ENDIF

        IF(istsb.EQ.2.OR.istsb.EQ.4) THEN

          pth=0.5d0*be34*sqrt(tau*vint(2)*max(0d0,1d0-cth**2))

          expy3=max(1.d-10,(1d0+rm3-rm4+be34*cth)/

     &    max(1.d-10,(1d0+rm3-rm4-be34*cth)))

          expy4=max(1.d-10,(1d0-rm3+rm4-be34*cth)/

     &    max(1.d-10,(1d0-rm3+rm4+be34*cth)))

          y3=yst+0.5d0*log(expy3)

          y4=yst+0.5d0*log(expy4)

          ylarge=max(y3,y4)

          ysmall=min(y3,y4)

          etalar=10d0

          etasma=-10d0

          sth=sqrt(max(0d0,1d0-cth**2))

          exsq3=sqrt(max(1d-20,((1d0+rm3-rm4)*cosh(yst)+be34*sinh(yst)*

     &    cth)**2-4d0*rm3))

          exsq4=sqrt(max(1d-20,((1d0-rm3+rm4)*cosh(yst)-be34*sinh(yst)*

     &    cth)**2-4d0*rm4))

          IF(sth.GE.1.d-6) THEN

            expet3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth+exsq3)/

     &      (be34*sth)

            expet4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth+exsq4)/

     &      (be34*sth)

            eta3=log(min(1.d10,max(1.d-10,expet3)))

            eta4=log(min(1.d10,max(1.d-10,expet4)))

            etalar=max(eta3,eta4)

            etasma=min(eta3,eta4)

          ENDIF

          cts3=((1d0+rm3-rm4)*sinh(yst)+be34*cosh(yst)*cth)/exsq3

          cts4=((1d0-rm3+rm4)*sinh(yst)-be34*cosh(yst)*cth)/exsq4

          ctslar=min(1d0,max(cts3,cts4))

          ctssma=max(-1d0,min(cts3,cts4))

          sh=tau*vint(2)

          rpts=4d0*vint(71)**2/sh

          be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))

          rm34=max(1d-20,2d0*rm3*rm4)

          IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)

     &    rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))

          rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)

          tha=0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)

          uha=0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)

          IF(pth.LT.pthmin) mint(51)=1

          IF(ckin(4).GE.0d0.AND.pth.GT.ckin(4)) mint(51)=1

          IF(ylarge.LT.ckin(9).OR.ylarge.GT.ckin(10)) mint(51)=1

          IF(ysmall.LT.ckin(11).OR.ysmall.GT.ckin(12)) mint(51)=1

          IF(etalar.LT.ckin(13).OR.etalar.GT.ckin(14)) mint(51)=1

          IF(etasma.LT.ckin(15).OR.etasma.GT.ckin(16)) mint(51)=1

          IF(ctslar.LT.ckin(17).OR.ctslar.GT.ckin(18)) mint(51)=1

          IF(ctssma.LT.ckin(19).OR.ctssma.GT.ckin(20)) mint(51)=1

          IF(cth.LT.ckin(27).OR.cth.GT.ckin(28)) mint(51)=1

          IF(tha.LT.ckin(35)) mint(51)=1

          IF(ckin(36).GE.0d0.AND.tha.GT.ckin(36)) mint(51)=1

          IF(uha.LT.ckin(37)) mint(51)=1

          IF(ckin(38).GE.0d0.AND.uha.GT.ckin(38)) mint(51)=1

        ENDIF

        IF(istsb.GE.3.AND.istsb.LE.5) THEN

          IF(taup*vint(2).LT.ckin(31)**2) mint(51)=1

          IF(ckin(32).GE.0d0.AND.taup*vint(2).GT.ckin(32)**2) mint(51)=1

        ENDIF


C...Additional cuts on W2 (approximately) in DIS.

        IF(isub.EQ.10) THEN

          xbj=x2

          IF(iabs(mint(12)).LT.20) xbj=x1

          q2bj=tha

          w2bj=q2bj*(1d0-xbj)/xbj

          IF(w2bj.LT.ckin(39)) mint(51)=1

          IF(ckin(40).GT.0d0.AND.w2bj.GT.ckin(40)) mint(51)=1

        ENDIF


      ELSEIF(ilim.EQ.1) THEN

C...Calculate limits on tau

C...0) due to definition

        taumn0=0d0

        taumx0=1d0

C...1) due to limits on subsystem mass

        taumn1=ckin(1)**2/vint(2)

        taumx1=1d0

        IF(ckin(2).GE.0d0) taumx1=ckin(2)**2/vint(2)

C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)

        tm3=sqrt(sqm3+pthmin**2)

        tm4=sqrt(sqm4+pthmin**2)

        ydcosh=1d0

        IF(ckin09.GT.ckin12) ydcosh=cosh(ckin09-ckin12)

        taumn2=(tm3**2+2d0*tm3*tm4*ydcosh+tm4**2)/vint(2)

        taumx2=1d0

C...3) due to limits on pT-hat and cos(theta-hat)

        cth2mn=min(ckin(27)**2,ckin(28)**2)

        cth2mx=max(ckin(27)**2,ckin(28)**2)

        taumn3=0d0

        IF(ckin(27)*ckin(28).GT.0d0) taumn3=

     &  (sqrt(sqm3+pthmin**2/(1d0-cth2mn))+

     &  sqrt(sqm4+pthmin**2/(1d0-cth2mn)))**2/vint(2)

        taumx3=1d0

        IF(ckin(4).GE.0d0.AND.cth2mx.LT.1d0) taumx3=

     &  (sqrt(sqm3+ckin(4)**2/(1d0-cth2mx))+

     &  sqrt(sqm4+ckin(4)**2/(1d0-cth2mx)))**2/vint(2)

C...4) due to limits on x1 and x2

        taumn4=ckin(21)*ckin(23)

        taumx4=ckin(22)*ckin(24)

C...5) due to limits on xF

        taumn5=0d0

        taumx5=max(1d0-ckin(25),1d0+ckin(26))

C...6) due to limits on that and uhat

        taumn6=(sqm3+sqm4+ckin(35)+ckin(37))/vint(2)

        taumx6=1d0

        IF(ckin(36).GT.0d0.AND.ckin(38).GT.0d0) taumx6=

     &  (sqm3+sqm4+ckin(36)+ckin(38))/vint(2)


C...Net effect of all separate limits.

        vint(11)=max(taumn0,taumn1,taumn2,taumn3,taumn4,taumn5,taumn6)

        vint(31)=min(taumx0,taumx1,taumx2,taumx3,taumx4,taumx5,taumx6)

        IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN

          vint(11)=0.99999d0

          vint(31)=1.00001d0

        ELSEIF(mint(47).EQ.5) THEN

          vint(31)=min(vint(31),0.999998d0)

        ENDIF

        IF(vint(31).LE.vint(11)) mint(51)=1


      ELSEIF(ilim.EQ.2) THEN

C...Calculate limits on y*

        taue=tau

        IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)

        taurt=sqrt(taue)

C...0) due to kinematics

        ystmn0=log(taurt)

        ystmx0=-ystmn0

C...1) due to explicit limits

        ystmn1=ckin(7)

        ystmx1=ckin(8)

C...2) due to limits on x1

        ystmn2=log(max(taue,ckin(21))/taurt)

        ystmx2=log(max(taue,ckin(22))/taurt)

C...3) due to limits on x2

        ystmn3=-log(max(taue,ckin(24))/taurt)

        ystmx3=-log(max(taue,ckin(23))/taurt)

C...4) due to limits on xF

        yepmn4=0.5d0*abs(ckin(25))/taurt

        ystmn4=sign(log(max(1d-20,sqrt(1d0+yepmn4**2)+yepmn4)),ckin(25))

        yepmx4=0.5d0*abs(ckin(26))/taurt

        ystmx4=sign(log(max(1d-20,sqrt(1d0+yepmx4**2)+yepmx4)),ckin(26))

C...5) due to simultaneous limits on y-large and y-small

        yepsmn=(rm3-rm4)*sinh(ckin09-ckin11)

        yepsmx=(rm3-rm4)*sinh(ckin10-ckin12)

        ydifmn=abs(log(max(1d-20,sqrt(1d0+yepsmn**2)-yepsmn)))

        ydifmx=abs(log(max(1d-20,sqrt(1d0+yepsmx**2)-yepsmx)))

        ystmn5=0.5d0*(ckin09+ckin11-ydifmn)

        ystmx5=0.5d0*(ckin10+ckin12+ydifmx)

C...6) due to simultaneous limits on cos(theta-hat) and y-large or

C...   y-small

        cthlim=sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*taue*vint(2))))

        rzmn=be34*max(ckin(27),-cthlim)

        rzmx=be34*min(ckin(28),cthlim)

        yex3mx=(1d0+rm3-rm4+rzmx)/max(1d-10,1d0+rm3-rm4-rzmx)

        yex4mx=(1d0+rm4-rm3-rzmn)/max(1d-10,1d0+rm4-rm3+rzmn)

        yex3mn=max(1d-10,1d0+rm3-rm4+rzmn)/(1d0+rm3-rm4-rzmn)

        yex4mn=max(1d-10,1d0+rm4-rm3-rzmx)/(1d0+rm4-rm3+rzmx)

        ystmn6=ckin09-0.5d0*log(max(yex3mx,yex4mx))

        ystmx6=ckin12-0.5d0*log(min(yex3mn,yex4mn))


C...Net effect of all separate limits.

        vint(12)=max(ystmn0,ystmn1,ystmn2,ystmn3,ystmn4,ystmn5,ystmn6)

        vint(32)=min(ystmx0,ystmx1,ystmx2,ystmx3,ystmx4,ystmx5,ystmx6)

        IF(mint(47).EQ.1) THEN

          vint(12)=-0.00001d0

          vint(32)=0.00001d0

        ELSEIF(mint(47).EQ.2) THEN

          vint(12)=0.99999d0*ystmx0

          vint(32)=1.00001d0*ystmx0

        ELSEIF(mint(47).EQ.3) THEN

          vint(12)=-1.00001d0*ystmx0

          vint(32)=-0.99999d0*ystmx0

        ELSEIF(mint(47).EQ.5) THEN

          ystee=log(0.999999d0/taurt)

          vint(12)=max(vint(12),-ystee)

          vint(32)=min(vint(32),ystee)

        ENDIF

        IF(vint(32).LE.vint(12)) mint(51)=1


      ELSEIF(ilim.EQ.3) THEN

C...Calculate limits on cos(theta-hat)

        yst=vint(22)

C...0) due to definition

        ctnmn0=-1d0

        ctnmx0=0d0

        ctpmn0=0d0

        ctpmx0=1d0

C...1) due to explicit limits

        ctnmn1=min(0d0,ckin(27))

        ctnmx1=min(0d0,ckin(28))

        ctpmn1=max(0d0,ckin(27))

        ctpmx1=max(0d0,ckin(28))

C...2) due to limits on pT-hat

        ctnmn2=-sqrt(max(0d0,1d0-4d0*pthmin**2/(be34**2*tau*vint(2))))

        ctpmx2=-ctnmn2

        ctnmx2=0d0

        ctpmn2=0d0

        IF(ckin(4).GE.0d0) THEN

          ctnmx2=-sqrt(max(0d0,1d0-4d0*ckin(4)**2/

     &    (be34**2*tau*vint(2))))

          ctpmn2=-ctnmx2

        ENDIF

C...3) due to limits on y-large and y-small

        ctnmn3=min(0d0,max((1d0+rm3-rm4)/be34*tanh(ckin11-yst),

     &  -(1d0-rm3+rm4)/be34*tanh(ckin10-yst)))

        ctnmx3=min(0d0,(1d0+rm3-rm4)/be34*tanh(ckin12-yst),

     &  -(1d0-rm3+rm4)/be34*tanh(ckin09-yst))

        ctpmn3=max(0d0,(1d0+rm3-rm4)/be34*tanh(ckin09-yst),

     &  -(1d0-rm3+rm4)/be34*tanh(ckin12-yst))

        ctpmx3=max(0d0,min((1d0+rm3-rm4)/be34*tanh(ckin10-yst),

     &  -(1d0-rm3+rm4)/be34*tanh(ckin11-yst)))

C...4) due to limits on that

        ctnmn4=-1d0

        ctnmx4=0d0

        ctpmn4=0d0

        ctpmx4=1d0

        sh=tau*vint(2)

        IF(ckin(35).GT.0d0) THEN

          ctlim=(1d0-rm3-rm4-2d0*ckin(35)/sh)/be34

          IF(ctlim.GT.0d0) THEN

            ctpmx4=ctlim

          ELSE

            ctpmx4=0d0

            ctnmx4=ctlim

          ENDIF

        ENDIF

        IF(ckin(36).GT.0d0) THEN

          ctlim=(1d0-rm3-rm4-2d0*ckin(36)/sh)/be34

          IF(ctlim.LT.0d0) THEN

            ctnmn4=ctlim

          ELSE

            ctnmn4=0d0

            ctpmn4=ctlim

          ENDIF

        ENDIF

C...5) due to limits on uhat

        ctnmn5=-1d0

        ctnmx5=0d0

        ctpmn5=0d0

        ctpmx5=1d0

        IF(ckin(37).GT.0d0) THEN

          ctlim=(2d0*ckin(37)/sh-(1d0-rm3-rm4))/be34

          IF(ctlim.LT.0d0) THEN

            ctnmn5=ctlim

          ELSE

            ctnmn5=0d0

            ctpmn5=ctlim

          ENDIF

        ENDIF

        IF(ckin(38).GT.0d0) THEN

          ctlim=(2d0*ckin(38)/sh-(1d0-rm3-rm4))/be34

          IF(ctlim.GT.0d0) THEN

            ctpmx5=ctlim

          ELSE

            ctpmx5=0d0

            ctnmx5=ctlim

          ENDIF

        ENDIF


C...Net effect of all separate limits.

        vint(13)=max(ctnmn0,ctnmn1,ctnmn2,ctnmn3,ctnmn4,ctnmn5)

        vint(33)=min(ctnmx0,ctnmx1,ctnmx2,ctnmx3,ctnmx4,ctnmx5)

        vint(14)=max(ctpmn0,ctpmn1,ctpmn2,ctpmn3,ctpmn4,ctpmn5)

        vint(34)=min(ctpmx0,ctpmx1,ctpmx2,ctpmx3,ctpmx4,ctpmx5)

        IF(vint(33).LE.vint(13).AND.vint(34).LE.vint(14)) mint(51)=1


      ELSEIF(ilim.EQ.4) THEN

C...Calculate limits on tau'

C...0) due to kinematics

        tapmn0=tau

        IF(istsb.EQ.5.AND.kfpr(isub,2).GT.0) THEN

          pqrat=2d0*pmas(pycomp(kfpr(isub,2)),1)/vint(1)

          tapmn0=(sqrt(tau)+pqrat)**2

        ENDIF

        tapmx0=1d0

C...1) due to explicit limits

        tapmn1=ckin(31)**2/vint(2)

        tapmx1=1d0

        IF(ckin(32).GE.0d0) tapmx1=ckin(32)**2/vint(2)


C...Net effect of all separate limits.

        vint(16)=max(tapmn0,tapmn1)

        vint(36)=min(tapmx0,tapmx1)

        IF(mint(47).EQ.1) THEN

          vint(16)=0.99999d0

          vint(36)=1.00001d0

        ENDIF

        IF(vint(36).LE.vint(16)) mint(51)=1


      ENDIF

      RETURN


C...Special case for low-pT and multiple interactions:

C...effective kinematical limits for tau, y*, cos(theta-hat).

  100 IF(ilim.EQ.0) THEN

      ELSEIF(ilim.EQ.1) THEN

        IF(mstp(82).LE.1) vint(11)=4d0*parp(81)**2/vint(2)

        IF(mstp(82).GE.2) vint(11)=parp(82)**2/vint(2)

        vint(31)=1d0

      ELSEIF(ilim.EQ.2) THEN

        vint(12)=0.5d0*log(vint(21))

        vint(32)=-vint(12)

      ELSEIF(ilim.EQ.3) THEN

        IF(mstp(82).LE.1) st2eff=4d0*parp(81)**2/(vint(21)*vint(2))

        IF(mstp(82).GE.2) st2eff=0.01d0*parp(82)**2/(vint(21)*vint(2))

        vint(13)=-sqrt(max(0d0,1d0-st2eff))

        vint(33)=0d0

        vint(14)=0d0

        vint(34)=-vint(13)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYKMAP

C...Maps a uniform distribution into a distribution of a kinematical

C...variable according to one of the possibilities allowed. It is

C...assumed that kinematical limits have been set by a PYKLIM call.


      SUBROUTINE pykmap(IVAR,MVAR,VVAR)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pydat1/,/pydat2/,/pysubs/,/pypars/,/pyint1/,/pyint2/


C...Convert VVAR to tau variable.

      isub=mint(1)

      istsb=iset(isub)

      IF(ivar.EQ.1) THEN

        taumin=vint(11)

        taumax=vint(31)

        IF(mvar.EQ.3.OR.mvar.EQ.4) THEN

          taure=vint(73)

          gamre=vint(74)

        ELSEIF(mvar.EQ.5.OR.mvar.EQ.6) THEN

          taure=vint(75)

          gamre=vint(76)

        ENDIF

        IF(mint(47).EQ.1.AND.(istsb.EQ.1.OR.istsb.EQ.2)) THEN

          tau=1d0

        ELSEIF(mvar.EQ.1) THEN

          tau=taumin*(taumax/taumin)**vvar

        ELSEIF(mvar.EQ.2) THEN

          tau=taumax*taumin/(taumin+(taumax-taumin)*vvar)

        ELSEIF(mvar.EQ.3.OR.mvar.EQ.5) THEN

          ratgen=(taure+taumax)/(taure+taumin)*taumin/taumax

          tau=taure*taumin/((taure+taumin)*ratgen**vvar-taumin)

        ELSEIF(mvar.EQ.4.OR.mvar.EQ.6) THEN

          aupp=atan((taumax-taure)/gamre)

          alow=atan((taumin-taure)/gamre)

          tau=taure+gamre*tan(alow+(aupp-alow)*vvar)

        ELSE

          aupp=log(max(2d-6,1d0-taumax))

          alow=log(max(2d-6,1d0-taumin))

          tau=1d0-exp(aupp+vvar*(alow-aupp))

        ENDIF

        vint(21)=min(taumax,max(taumin,tau))


C...Convert VVAR to y* variable.

      ELSEIF(ivar.EQ.2) THEN

        ystmin=vint(12)

        ystmax=vint(32)

        taue=vint(21)

        IF(istsb.GE.3.AND.istsb.LE.5) taue=vint(26)

        IF(mint(47).EQ.1) THEN

          yst=0d0

        ELSEIF(mint(47).EQ.2) THEN

          yst=-0.5d0*log(taue)

        ELSEIF(mint(47).EQ.3) THEN

          yst=0.5d0*log(taue)

        ELSEIF(mvar.EQ.1) THEN

          yst=ystmin+(ystmax-ystmin)*sqrt(vvar)

        ELSEIF(mvar.EQ.2) THEN

          yst=ystmax-(ystmax-ystmin)*sqrt(1d0-vvar)

        ELSEIF(mvar.EQ.3) THEN

          aupp=atan(exp(ystmax))

          alow=atan(exp(ystmin))

          yst=log(tan(alow+(aupp-alow)*vvar))

        ELSEIF(mvar.EQ.4) THEN

          yst0=-0.5d0*log(taue)

          aupp=log(max(1d-6,exp(yst0-ystmin)-1d0))

          alow=log(max(1d-6,exp(yst0-ystmax)-1d0))

          yst=yst0-log(1d0+exp(alow+vvar*(aupp-alow)))

        ELSE

          yst0=-0.5d0*log(taue)

          aupp=log(max(1d-6,exp(yst0+ystmin)-1d0))

          alow=log(max(1d-6,exp(yst0+ystmax)-1d0))

          yst=log(1d0+exp(aupp+vvar*(alow-aupp)))-yst0

        ENDIF

        vint(22)=min(ystmax,max(ystmin,yst))


C...Convert VVAR to cos(theta-hat) variable.

      ELSEIF(ivar.EQ.3) THEN

        rm34=max(1d-20,2d0*vint(63)*vint(64)/(vint(21)*vint(2))**2)

        rsqm=1d0+rm34

        IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0)

     &  rm34=max(rm34,2d0*vint(71)**2/(vint(21)*vint(2)))

        ctnmin=vint(13)

        ctnmax=vint(33)

        ctpmin=vint(14)

        ctpmax=vint(34)

        IF(mvar.EQ.1) THEN

          aneg=ctnmax-ctnmin

          apos=ctpmax-ctpmin

          IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN

            vctn=vvar*(aneg+apos)/aneg

            cth=ctnmin+(ctnmax-ctnmin)*vctn

          ELSE

            vctp=(vvar*(aneg+apos)-aneg)/apos

            cth=ctpmin+(ctpmax-ctpmin)*vctp

          ENDIF

        ELSEIF(mvar.EQ.2) THEN

          rmnmin=max(rm34,rsqm-ctnmin)

          rmnmax=max(rm34,rsqm-ctnmax)

          rmpmin=max(rm34,rsqm-ctpmin)

          rmpmax=max(rm34,rsqm-ctpmax)

          aneg=log(rmnmin/rmnmax)

          apos=log(rmpmin/rmpmax)

          IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN

            vctn=vvar*(aneg+apos)/aneg

            cth=rsqm-rmnmin*(rmnmax/rmnmin)**vctn

          ELSE

            vctp=(vvar*(aneg+apos)-aneg)/apos

            cth=rsqm-rmpmin*(rmpmax/rmpmin)**vctp

          ENDIF

        ELSEIF(mvar.EQ.3) THEN

          rmnmin=max(rm34,rsqm+ctnmin)

          rmnmax=max(rm34,rsqm+ctnmax)

          rmpmin=max(rm34,rsqm+ctpmin)

          rmpmax=max(rm34,rsqm+ctpmax)

          aneg=log(rmnmax/rmnmin)

          apos=log(rmpmax/rmpmin)

          IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN

            vctn=vvar*(aneg+apos)/aneg

            cth=rmnmin*(rmnmax/rmnmin)**vctn-rsqm

          ELSE

            vctp=(vvar*(aneg+apos)-aneg)/apos

            cth=rmpmin*(rmpmax/rmpmin)**vctp-rsqm

          ENDIF

        ELSEIF(mvar.EQ.4) THEN

          rmnmin=max(rm34,rsqm-ctnmin)

          rmnmax=max(rm34,rsqm-ctnmax)

          rmpmin=max(rm34,rsqm-ctpmin)

          rmpmax=max(rm34,rsqm-ctpmax)

          aneg=1d0/rmnmax-1d0/rmnmin

          apos=1d0/rmpmax-1d0/rmpmin

          IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN

            vctn=vvar*(aneg+apos)/aneg

            cth=rsqm-1d0/(1d0/rmnmin+aneg*vctn)

          ELSE

            vctp=(vvar*(aneg+apos)-aneg)/apos

            cth=rsqm-1d0/(1d0/rmpmin+apos*vctp)

          ENDIF

        ELSEIF(mvar.EQ.5) THEN

          rmnmin=max(rm34,rsqm+ctnmin)

          rmnmax=max(rm34,rsqm+ctnmax)

          rmpmin=max(rm34,rsqm+ctpmin)

          rmpmax=max(rm34,rsqm+ctpmax)

          aneg=1d0/rmnmin-1d0/rmnmax

          apos=1d0/rmpmin-1d0/rmpmax

          IF(aneg.GT.0d0.AND.vvar*(aneg+apos).LE.aneg) THEN

            vctn=vvar*(aneg+apos)/aneg

            cth=1d0/(1d0/rmnmin-aneg*vctn)-rsqm

          ELSE

            vctp=(vvar*(aneg+apos)-aneg)/apos

            cth=1d0/(1d0/rmpmin-apos*vctp)-rsqm

          ENDIF

        ENDIF

        IF(cth.LT.0d0) cth=min(ctnmax,max(ctnmin,cth))

        IF(cth.GT.0d0) cth=min(ctpmax,max(ctpmin,cth))

        vint(23)=cth


C...Convert VVAR to tau' variable.

      ELSEIF(ivar.EQ.4) THEN

        tau=vint(21)

        taupmn=vint(16)

        taupmx=vint(36)

        IF(mint(47).EQ.1) THEN

          taup=1d0

        ELSEIF(mvar.EQ.1) THEN

          taup=taupmn*(taupmx/taupmn)**vvar

        ELSEIF(mvar.EQ.2) THEN

          aupp=(1d0-tau/taupmx)**4

          alow=(1d0-tau/taupmn)**4

          taup=tau/max(1d-7,1d0-(alow+(aupp-alow)*vvar)**0.25d0)

        ELSE

          aupp=log(max(2d-6,1d0-taupmx))

          alow=log(max(2d-6,1d0-taupmn))

          taup=1d0-exp(aupp+vvar*(alow-aupp))

        ENDIF

        vint(26)=min(taupmx,max(taupmn,taup))


C...Selection of extra variables needed in 2 -> 3 process:

C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.

C...Since no options are available, the functions of PYKLIM

C...and PYKMAP are joint for these choices.

      ELSEIF(ivar.EQ.5) THEN


C...Read out total energy and particle masses.

        mint(51)=0

        mptpk=1

        IF(isub.EQ.123.OR.isub.EQ.124.OR.isub.EQ.173.OR.isub.EQ.174

     &  .OR.isub.EQ.178.OR.isub.EQ.179) mptpk=2

        shp=vint(26)*vint(2)

        shpr=sqrt(shp)

        pm1=vint(201)

        pm2=vint(206)

        pm3=sqrt(vint(21))*vint(1)

        IF(pm1+pm2+pm3.GT.0.9999d0*shpr) THEN

          mint(51)=1

          RETURN

        ENDIF

        pmrs1=vint(204)**2

        pmrs2=vint(209)**2


C...Specify coefficients of pT choice; upper and lower limits.

        IF(mptpk.EQ.1) THEN

          hwt1=0.4d0

          hwt2=0.4d0

        ELSE

          hwt1=0.05d0

          hwt2=0.05d0

        ENDIF

        hwt3=1d0-hwt1-hwt2

        ptsmx1=((shp-pm1**2-(pm2+pm3)**2)**2-(2d0*pm1*(pm2+pm3))**2)/

     &  (4d0*shp)

        IF(ckin(52).GT.0d0) ptsmx1=min(ptsmx1,ckin(52)**2)

        ptsmn1=ckin(51)**2

        ptsmx2=((shp-pm2**2-(pm1+pm3)**2)**2-(2d0*pm2*(pm1+pm3))**2)/

     &  (4d0*shp)

        IF(ckin(54).GT.0d0) ptsmx2=min(ptsmx2,ckin(54)**2)

        ptsmn2=ckin(53)**2


C...Select transverse momenta according to

C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).

        hmx=pmrs1+ptsmx1

        hmn=pmrs1+ptsmn1

        IF(hmx.LT.1.0001d0*hmn) THEN

          mint(51)=1

          RETURN

        ENDIF

        hde=ptsmx1-ptsmn1

        rpt=pyr(0)

        IF(rpt.LT.hwt1) THEN

          pts1=ptsmn1+pyr(0)*hde

        ELSEIF(rpt.LT.hwt1+hwt2) THEN

          pts1=max(ptsmn1,hmn*(hmx/hmn)**pyr(0)-pmrs1)

        ELSE

          pts1=max(ptsmn1,hmn*hmx/(hmn+pyr(0)*hde)-pmrs1)

        ENDIF

        wtpts1=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs1+pts1))+

     &  hwt3*hmn*hmx/(pmrs1+pts1)**2)

        hmx=pmrs2+ptsmx2

        hmn=pmrs2+ptsmn2

        IF(hmx.LT.1.0001d0*hmn) THEN

          mint(51)=1

          RETURN

        ENDIF

        hde=ptsmx2-ptsmn2

        rpt=pyr(0)

        IF(rpt.LT.hwt1) THEN

          pts2=ptsmn2+pyr(0)*hde

        ELSEIF(rpt.LT.hwt1+hwt2) THEN

          pts2=max(ptsmn2,hmn*(hmx/hmn)**pyr(0)-pmrs2)

        ELSE

          pts2=max(ptsmn2,hmn*hmx/(hmn+pyr(0)*hde)-pmrs2)

        ENDIF

        wtpts2=hde/(hwt1+hwt2*hde/(log(hmx/hmn)*(pmrs2+pts2))+

     &  hwt3*hmn*hmx/(pmrs2+pts2)**2)


C...Select azimuthal angles and check pT choice.

        phi1=paru(2)*pyr(0)

        phi2=paru(2)*pyr(0)

        phir=phi2-phi1

        pts3=max(0d0,pts1+pts2+2d0*sqrt(pts1*pts2)*cos(phir))

        IF(pts3.LT.ckin(55)**2.OR.(ckin(56).GT.0d0.AND.pts3.GT.

     &  ckin(56)**2)) THEN

          mint(51)=1

          RETURN

        ENDIF


C...Calculate transverse masses and check phase space not closed.

        pms1=pm1**2+pts1

        pms2=pm2**2+pts2

        pms3=pm3**2+pts3

        pmt1=sqrt(pms1)

        pmt2=sqrt(pms2)

        pmt3=sqrt(pms3)

        pm12=(pmt1+pmt2)**2

        IF(pmt1+pmt2+pmt3.GT.0.9999d0*shpr) THEN

          mint(51)=1

          RETURN

        ENDIF


C...Select rapidity for particle 3 and check phase space not closed.

        y3max=log((shp+pms3-pm12+sqrt(max(0d0,(shp-pms3-pm12)**2-

     &  4d0*pms3*pm12)))/(2d0*shpr*pmt3))

        IF(y3max.LT.1d-6) THEN

          mint(51)=1

          RETURN

        ENDIF

        y3=(2d0*pyr(0)-1d0)*0.999999d0*y3max

        pz3=pmt3*sinh(y3)

        pe3=pmt3*cosh(y3)


C...Find momentum transfers in two mirror solutions (in 1-2 frame).

        pz12=-pz3

        pe12=shpr-pe3

        pms12=pe12**2-pz12**2

        sql12=sqrt(max(0d0,(pms12-pms1-pms2)**2-4d0*pms1*pms2))

        IF(sql12.LT.1d-6*shp) THEN

          mint(51)=1

          RETURN

        ENDIF

        pmm1=pms12+pms1-pms2

        pmm2=pms12+pms2-pms1

        tfac=-shpr/(2d0*pms12)

        t1p=tfac*(pe12-pz12)*(pmm1-sql12)

        t1n=tfac*(pe12-pz12)*(pmm1+sql12)

        t2p=tfac*(pe12+pz12)*(pmm2-sql12)

        t2n=tfac*(pe12+pz12)*(pmm2+sql12)


C...Construct relative mirror weights and make choice.

        IF(mptpk.EQ.1) THEN

          wtpu=1d0

          wtnu=1d0

        ELSE

          wtpu=1d0/((t1p-pmrs1)*(t2p-pmrs2))**2

          wtnu=1d0/((t1n-pmrs1)*(t2n-pmrs2))**2

        ENDIF

        wtp=wtpu/(wtpu+wtnu)

        wtn=wtnu/(wtpu+wtnu)

        eps=1d0

        IF(wtn.GT.pyr(0)) eps=-1d0


C...Store result of variable choice and associated weights.

        vint(202)=pts1

        vint(207)=pts2

        vint(203)=phi1

        vint(208)=phi2

        vint(205)=wtpts1

        vint(210)=wtpts2

        vint(211)=y3

        vint(212)=y3max

        vint(213)=eps

        IF(eps.GT.0d0) THEN

          vint(214)=1d0/wtp

          vint(215)=t1p

          vint(216)=t2p

        ELSE

          vint(214)=1d0/wtn

          vint(215)=t1n

          vint(216)=t2n

        ENDIF

        vint(217)=-0.5d0*tfac*(pe12-pz12)*(pmm2+eps*sql12)

        vint(218)=-0.5d0*tfac*(pe12+pz12)*(pmm1+eps*sql12)

        vint(219)=0.5d0*(pms12-pts3)

        vint(220)=sql12

      ENDIF


      RETURN

      END


C***********************************************************************


C...PYSIGH

C...Differential matrix elements for all included subprocesses

C...Note that what is coded is (disregarding the COMFAC factor)

C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,

C...when d(sigma-hat) is given in the zero-width limit, the delta

C...function in tau is replaced by a (modified) Breit-Wigner:

C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),

C...where H_res = s-hat/m_res*Gamma_res(s-hat);

C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);

C...i.e., dimensionless quantities

C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is

C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *

C...(2pi)^4 delta^4(P - sum p_i)

C...COMFAC contains the factor pi/s (or equivalent) and

C...the conversion factor from GeV^-2 to mb


      SUBROUTINE pysigh(NCHN,SIGS)


C...Double precision and integer declarations

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint7/sigt(0:6,0:6,0:5)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pysubs/,/pypars/,

     &/pyint1/,/pyint2/,/pyint3/,/pyint4/,/pyint5/,/pyint7/,

     &/pyssmt/

C...Local arrays and complex variables

      dimension x(2),xpq(-25:25),kfac(2,-40:40),wdtp(0:200),

     &wdte(0:200,0:5),hgz(6,3),hl3(3),hr3(3),hl4(3),hr4(3)

      COMPLEX a004,a204,a114,a00u,a20u,a11u

      COMPLEX cigtot,ciztot,f0alp,f1alp,f2alp,f0bet,f1bet,f2bet,fif,

     &coulck,coulcp,coulcd,coulcr,coulcs

      REAL a00l,a11l,a20l,coulxx


C...Reset number of channels and cross-section

      nchn=0

      sigs=0d0


C...Convert H or A process into equivalent h one

      isub=mint(1)

      isubsv=isub

      ihigg=1

      kfhigg=25

      IF((isub.GE.151.AND.isub.LE.160).OR.(isub.GE.171.AND.

     &isub.LE.190)) THEN

        ihigg=2

        IF(mod(isub-1,10).GE.5) ihigg=3

        kfhigg=33+ihigg

        IF(isub.EQ.151.OR.isub.EQ.156) isub=3

        IF(isub.EQ.152.OR.isub.EQ.157) isub=102

        IF(isub.EQ.153.OR.isub.EQ.158) isub=103

        IF(isub.EQ.171.OR.isub.EQ.176) isub=24

        IF(isub.EQ.172.OR.isub.EQ.177) isub=26

        IF(isub.EQ.173.OR.isub.EQ.178) isub=123

        IF(isub.EQ.174.OR.isub.EQ.179) isub=124

        IF(isub.EQ.181.OR.isub.EQ.186) isub=121

        IF(isub.EQ.182.OR.isub.EQ.187) isub=122

      ENDIF


CMRENNA++

C...Convert almost equivalent SUSY processes into each other

C...Extract differences in flavours and couplings

      IF(isub.GE.200.AND.isub.LE.280) THEN


C...Sleptons and sneutrinos

        IF(isub.EQ.201.OR.isub.EQ.204.OR.isub.EQ.207) THEN

          kfid=mod(kfpr(isub,1),ksusy1)

          isub=201

          ilr=0

        ELSEIF(isub.EQ.202.OR.isub.EQ.205.OR.isub.EQ.208) THEN

          kfid=mod(kfpr(isub,1),ksusy1)

          isub=201

          ilr=1

        ELSEIF(isub.EQ.203.OR.isub.EQ.206.OR.isub.EQ.209) THEN

          kfid=mod(kfpr(isub,1),ksusy1)

          isub=203

        ELSEIF(isub.GE.210.AND.isub.LE.212) THEN

          IF(isub.EQ.210) THEN

            rkf=2.0d0

          ELSEIF(isub.EQ.211) THEN

            rkf=sfmix(15,1)**2

          ELSEIF(isub.EQ.212) THEN

            rkf=sfmix(15,2)**2

          ENDIF

          isub=210

        ELSEIF(isub.EQ.213.OR.isub.EQ.214) THEN

          IF(isub.EQ.213) THEN

            kfid=mod(kfpr(isub,1),ksusy1)

            rkf=2.0d0

          ELSEIF(isub.EQ.214) THEN

            kfid=16

            rkf=1.0d0

          ENDIF

          isub=213


C...Neutralinos

        ELSEIF(isub.GE.216.AND.isub.LE.225) THEN

          IF(isub.EQ.216) THEN

            izid1=1

            izid2=1

          ELSEIF(isub.EQ.217) THEN

            izid1=2

            izid2=2

          ELSEIF(isub.EQ.218) THEN

            izid1=3

            izid2=3

          ELSEIF(isub.EQ.219) THEN

            izid1=4

            izid2=4

          ELSEIF(isub.EQ.220) THEN

            izid1=1

            izid2=2

          ELSEIF(isub.EQ.221) THEN

            izid1=1

            izid2=3

          ELSEIF(isub.EQ.222) THEN

            izid1=1

            izid2=4

          ELSEIF(isub.EQ.223) THEN

            izid1=2

            izid2=3

          ELSEIF(isub.EQ.224) THEN

            izid1=2

            izid2=4

          ELSEIF(isub.EQ.225) THEN

            izid1=3

            izid2=4

          ENDIF

          isub=216


C...Charginos

        ELSEIF(isub.GE.226.AND.isub.LE.228) THEN

          IF(isub.EQ.226) THEN

            izid1=1

            izid2=1

          ELSEIF(isub.EQ.227) THEN

            izid1=2

            izid2=2

          ELSEIF(isub.EQ.228) THEN

            izid1=1

            izid2=2

          ENDIF

          isub=226


C...Neutralino + chargino

        ELSEIF(isub.GE.229.AND.isub.LE.236) THEN

          IF(isub.EQ.229) THEN

            izid1=1

            izid2=1

          ELSEIF(isub.EQ.230) THEN

            izid1=1

            izid2=2

          ELSEIF(isub.EQ.231) THEN

            izid1=1

            izid2=3

          ELSEIF(isub.EQ.232) THEN

            izid1=1

            izid2=4

          ELSEIF(isub.EQ.233) THEN

            izid1=2

            izid2=1

          ELSEIF(isub.EQ.234) THEN

            izid1=2

            izid2=2

          ELSEIF(isub.EQ.235) THEN

            izid1=2

            izid2=3

          ELSEIF(isub.EQ.236) THEN

            izid1=2

            izid2=4

          ENDIF

          isub=229


C...Gluino + neutralino

        ELSEIF(isub.GE.237.AND.isub.LE.240) THEN

          IF(isub.EQ.237) THEN

            izid=1

          ELSEIF(isub.EQ.238) THEN

            izid=2

          ELSEIF(isub.EQ.239) THEN

            izid=3

          ELSEIF(isub.EQ.240) THEN

            izid=4

          ENDIF

          isub=237


C...Gluino + chargino

        ELSEIF(isub.GE.241.AND.isub.LE.242) THEN

          IF(isub.EQ.241) THEN

            izid=1

          ELSEIF(isub.EQ.242) THEN

            izid=2

          ENDIF

          isub=241


C...Squark + neutralino

        ELSEIF(isub.GE.246.AND.isub.LE.253) THEN

          ilr=0

          IF(mod(isub,2).NE.0) ilr=1

          IF(isub.LE.247) THEN

            izid=1

          ELSEIF(isub.LE.249) THEN

            izid=2

          ELSEIF(isub.LE.251) THEN

            izid=3

          ELSEIF(isub.LE.253) THEN

            izid=4

          ENDIF

          isub=246

          rkf=5d0


C...Squark + chargino

        ELSEIF(isub.GE.254.AND.isub.LE.257) THEN

          IF(isub.LE.255) THEN

            izid=1

          ELSEIF(isub.LE.257) THEN

            izid=2

          ENDIF

          IF(mod(isub,2).EQ.0) THEN

            ilr=0

          ELSE

            ilr=1

          ENDIF

          isub=254

          rkf=5d0


C...Squark + gluino

        ELSEIF(isub.EQ.258.OR.isub.EQ.259) THEN

          isub=258

          rkf=5d0


C...Stops

        ELSEIF(isub.EQ.261.OR.isub.EQ.262) THEN

          ilr=0

          IF(isub.EQ.262) ilr=1

          isub=261

        ELSEIF(isub.EQ.265) THEN

          isub=264


C...Squarks

        ELSEIF(isub.GE.271.AND.isub.LE.280) THEN

          ilr=0

          IF(isub.LE.273) THEN

            IF(isub.EQ.273) ilr=1

            isub=271

            rkf=25d0

          ELSEIF(isub.LE.276) THEN

            IF(isub.EQ.276) ilr=1

            isub=274

            rkf=25d0

          ELSEIF(isub.LE.278) THEN

            IF(isub.EQ.278) ilr=1

            isub=277

            rkf=5d0

          ELSE

            IF(isub.EQ.280) ilr=1

            isub=279

            rkf=5d0

          ENDIF

        ENDIF

      ENDIF

CMRENNA--


C...Read kinematical variables and limits

      istsb=iset(isubsv)

      taumin=vint(11)

      ystmin=vint(12)

      ctnmin=vint(13)

      ctpmin=vint(14)

      taupmn=vint(16)

      tau=vint(21)

      yst=vint(22)

      cth=vint(23)

      xt2=vint(25)

      taup=vint(26)

      taumax=vint(31)

      ystmax=vint(32)

      ctnmax=vint(33)

      ctpmax=vint(34)

      taupmx=vint(36)


C...Derive kinematical quantities

      taue=tau

      IF(istsb.GE.3.AND.istsb.LE.5) taue=taup

      x(1)=sqrt(taue)*exp(yst)

      x(2)=sqrt(taue)*exp(-yst)

      IF(mint(45).EQ.2.AND.istsb.GE.1) THEN

        IF(x(1).GT.0.9999d0) RETURN

      ELSEIF(mint(45).EQ.3) THEN

        x(1)=min(0.9999989d0,x(1))

      ENDIF

      IF(mint(46).EQ.2.AND.istsb.GE.1) THEN

        IF(x(2).GT.0.9999d0) RETURN

      ELSEIF(mint(46).EQ.3) THEN

        x(2)=min(0.9999989d0,x(2))

      ENDIF

      sh=tau*vint(2)

      sqm3=vint(63)

      sqm4=vint(64)

      rm3=sqm3/sh

      rm4=sqm4/sh

      be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))

      rpts=4d0*vint(71)**2/sh

      be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))

      rm34=max(1d-20,2d0*rm3*rm4)

      rsqm=1d0+rm34

      IF(2d0*vint(71)**2/(vint(21)*vint(2)).LT.0.0001d0) rm34=max(rm34,

     &2d0*vint(71)**2/(vint(21)*vint(2)))

      rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)

      IF(istsb.EQ.0) THEN

        th=vint(45)

        uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)

        sqpth=max(vint(71)**2,0.25d0*sh*be34**2*vint(59)**2)

      ELSE

        th=-0.5d0*sh*max(rthm,1d0-rm3-rm4-be34*cth)

        uh=-0.5d0*sh*max(rthm,1d0-rm3-rm4+be34*cth)

        sqpth=max(vint(71)**2,0.25d0*sh*be34**2*(1d0-cth**2))

      ENDIF

      shr=sqrt(sh)

      sh2=sh**2

      th2=th**2

      uh2=uh**2


C...Choice of Q2 scale: hard, parton distributions, parton showers

      IF(istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5) THEN

        q2=sh

      ELSEIF(mod(istsb,2).EQ.0.OR.istsb.EQ.9) THEN

        IF(mstp(32).EQ.1) THEN

          q2=2d0*sh*th*uh/(sh**2+th**2+uh**2)

        ELSEIF(mstp(32).EQ.2) THEN

          q2=sqpth+0.5d0*(sqm3+sqm4)

        ELSEIF(mstp(32).EQ.3) THEN

          q2=min(-th,-uh)

        ELSEIF(mstp(32).EQ.4) THEN

          q2=sh

        ELSEIF(mstp(32).EQ.5) THEN

          q2=-th

        ENDIF

        IF(istsb.EQ.9) q2=sqpth

        IF((istsb.EQ.9.AND.mstp(82).GE.2).OR.(istsb.NE.9.AND.

     &  mstp(85).EQ.1)) q2=q2+parp(82)**2

      ENDIF

      q2sf=q2

      IF(istsb.GE.3.AND.istsb.LE.5) THEN

        q2sf=pmas(23,1)**2

        IF(isub.EQ.8.OR.isub.EQ.76.OR.isub.EQ.77.OR.isub.EQ.124)

     &  q2sf=pmas(24,1)**2

        IF(isub.EQ.121.OR.isub.EQ.122) THEN

          q2sf=pmas(pycomp(kfpr(isubsv,2)),1)**2

          IF(mstp(39).EQ.2) q2sf=q2sf+max(vint(202),vint(207))

          IF(mstp(39).EQ.3) q2sf=sh

          IF(mstp(39).EQ.4) q2sf=vint(26)*vint(2)

        ENDIF

      ENDIF

      q2ps=q2sf

      q2sf=q2sf*parp(34)

      IF(mstp(68).GE.2.AND.mint(47).EQ.5) q2sf=vint(2)

      IF(mstp(22).GE.1.AND.(isub.EQ.10.OR.isub.EQ.83).AND.

     &(mint(43).EQ.2.OR.mint(43).EQ.3)) THEN

        xbj=x(2)

        IF(mint(43).EQ.3) xbj=x(1)

        IF(mstp(22).EQ.1) THEN

          q2ps=-th

        ELSEIF(mstp(22).EQ.2) THEN

          q2ps=((1d0-xbj)/xbj)*(-th)

        ELSEIF(mstp(22).EQ.3) THEN

          q2ps=sqrt((1d0-xbj)/xbj)*(-th)

        ELSE

          q2ps=(1d0-xbj)*max(1d0,-log(xbj))*(-th)

        ENDIF

      ENDIF

      IF(mstp(68).GE.1.AND.mint(47).EQ.5) q2ps=vint(2)


C...Store derived kinematical quantities

      vint(41)=x(1)

      vint(42)=x(2)

      vint(44)=sh

      vint(43)=sqrt(sh)

      vint(45)=th

      vint(46)=uh

      vint(48)=sqpth

      vint(47)=sqrt(sqpth)

      vint(50)=taup*vint(2)

      vint(49)=sqrt(max(0d0,vint(50)))

      vint(52)=q2

      vint(51)=sqrt(q2)

      vint(54)=q2sf

      vint(53)=sqrt(q2sf)

      vint(56)=q2ps

      vint(55)=sqrt(q2ps)


C...Calculate parton distributions

      IF(istsb.LE.0) goto 170

      IF(mint(47).GE.2) THEN

        DO 110 i=3-min(2,mint(45)),min(2,mint(46))

          xsf=x(i)

          IF(istsb.EQ.9) xsf=x(i)/vint(142+i)

          mint(105)=mint(102+i)

          mint(109)=mint(106+i)

          IF(mstp(57).LE.1) THEN

            CALL pypdfu(mint(10+i),xsf,q2sf,xpq)

          ELSE

            CALL pypdfl(mint(10+i),xsf,q2sf,xpq)

          ENDIF

          DO 100 kfl=-25,25

            xsfx(i,kfl)=xpq(kfl)

  100     CONTINUE

  110   CONTINUE

      ENDIF


C...Calculate alpha_em, alpha_strong and K-factor

      xw=paru(102)

      xwv=xw

      IF(mstp(8).GE.2.OR.(isub.GE.71.AND.isub.LE.77)) xw=

     &1d0-(pmas(24,1)/pmas(23,1))**2

      xw1=1d0-xw

      xwc=1d0/(16d0*xw*xw1)

      aem=pyalem(q2)

      IF(mstp(8).GE.1) aem=sqrt(2d0)*paru(105)*pmas(24,1)**2*xw/paru(1)

      IF(mstp(33).NE.3) as=pyalps(parp(34)*q2)

      fack=1d0

      faca=1d0

      IF(mstp(33).EQ.1) THEN

        fack=parp(31)

      ELSEIF(mstp(33).EQ.2) THEN

        fack=parp(31)

        faca=parp(32)/parp(31)

      ELSEIF(mstp(33).EQ.3) THEN

        q2as=parp(33)*q2

        IF(istsb.EQ.9.AND.mstp(82).GE.2) q2as=q2as+

     &  paru(112)*parp(82)

        as=pyalps(q2as)

      ENDIF

      vint(138)=1d0

      vint(57)=aem

      vint(58)=as


C...Set flags for allowed reacting partons/leptons

      DO 140 i=1,2

        DO 120 j=-25,25

          kfac(i,j)=0

  120   CONTINUE

        IF(mint(44+i).EQ.1) THEN

          kfac(i,mint(10+i))=1

        ELSEIF(mint(40+i).EQ.1.AND.mstp(12).EQ.0) THEN

          kfac(i,mint(10+i))=1

          kfac(i,22)=1

          kfac(i,24)=1

          kfac(i,-24)=1

        ELSE

          DO 130 j=-25,25

            kfac(i,j)=kfin(i,j)

            IF(iabs(j).GT.mstp(58).AND.iabs(j).LE.10) kfac(i,j)=0

            IF(xsfx(i,j).LT.1d-10) kfac(i,j)=0

  130     CONTINUE

        ENDIF

  140 CONTINUE


C...Lower and upper limit for fermion flavour loops

      mmin1=0

      mmax1=0

      mmin2=0

      mmax2=0

      DO 150 j=-20,20

        IF(kfac(1,-j).EQ.1) mmin1=-j

        IF(kfac(1,j).EQ.1) mmax1=j

        IF(kfac(2,-j).EQ.1) mmin2=-j

        IF(kfac(2,j).EQ.1) mmax2=j

  150 CONTINUE

      mmina=min(mmin1,mmin2)

      mmaxa=max(mmax1,mmax2)


C...Common resonance mass and width combinations

      sqmz=pmas(23,1)**2

      sqmw=pmas(24,1)**2

      sqmh=pmas(kfhigg,1)**2

      gmmz=pmas(23,1)*pmas(23,2)

      gmmw=pmas(24,1)*pmas(24,2)

      gmmh=pmas(kfhigg,1)*pmas(kfhigg,2)

C...MRENNA+++

      zwid=pmas(23,2)

      wwid=pmas(24,2)

C...MRENNA---


C...Phase space integral in tau

      comfac=paru(1)*paru(5)/vint(2)

      IF(mint(41).EQ.2.AND.mint(42).EQ.2) comfac=comfac*fack

      IF((mint(47).GE.2.OR.(istsb.GE.3.AND.istsb.LE.5)).AND.

     &istsb.NE.9) THEN

        atau1=log(taumax/taumin)

        atau2=(taumax-taumin)/(taumax*taumin)

        h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/tau

        IF(mint(72).GE.1) THEN

          taur1=vint(73)

          gamr1=vint(74)

          ataud=log(taumax/taumin*(taumin+taur1)/(taumax+taur1))

          atau3=ataud/taur1

          IF(ataud.GT.1d-6) h1=h1+

     &    (atau1/atau3)*coef(isubsv,3)/(tau+taur1)

          ataud=atan((taumax-taur1)/gamr1)-atan((taumin-taur1)/gamr1)

          atau4=ataud/gamr1

          IF(ataud.GT.1d-6) h1=h1+

     &    (atau1/atau4)*coef(isubsv,4)*tau/((tau-taur1)**2+gamr1**2)

        ENDIF

        IF(mint(72).EQ.2) THEN

          taur2=vint(75)

          gamr2=vint(76)

          ataud=log(taumax/taumin*(taumin+taur2)/(taumax+taur2))

          atau5=ataud/taur2

          IF(ataud.GT.1d-6) h1=h1+

     &    (atau1/atau5)*coef(isubsv,5)/(tau+taur2)

          ataud=atan((taumax-taur2)/gamr2)-atan((taumin-taur2)/gamr2)

          atau6=ataud/gamr2

          IF(ataud.GT.1d-6) h1=h1+

     &    (atau1/atau6)*coef(isubsv,6)*tau/((tau-taur2)**2+gamr2**2)

        ENDIF

        IF(mint(47).EQ.5.AND.(istsb.LE.2.OR.istsb.GE.5)) THEN

          atau7=log(max(2d-6,1d0-taumin)/max(2d-6,1d0-taumax))

          IF(atau7.GT.1d-6) h1=h1+(atau1/atau7)*coef(isubsv,7)*tau/

     &    max(2d-6,1d0-tau)

        ENDIF

        comfac=comfac*atau1/(tau*h1)

      ENDIF


C...Phase space integral in y*

      IF(mint(47).GE.4.AND.istsb.NE.9) THEN

        ayst0=ystmax-ystmin

        IF(ayst0.LT.1d-6) THEN

          comfac=0d0

        ELSE

          ayst1=0.5d0*(ystmax-ystmin)**2

          ayst2=ayst1

          ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))

          h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+

     &    (ayst0/ayst2)*coef(isubsv,9)*(ystmax-yst)+

     &    (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)

          IF(mint(45).EQ.3) THEN

            yst0=-0.5d0*log(taue)

            ayst4=log(max(1d-6,exp(yst0-ystmin)-1d0)/

     &      max(1d-6,exp(yst0-ystmax)-1d0))

            IF(ayst4.GT.1d-6) h2=h2+(ayst0/ayst4)*coef(isubsv,11)/

     &      max(1d-6,1d0-exp(yst-yst0))

          ENDIF

          IF(mint(46).EQ.3) THEN

            yst0=-0.5d0*log(taue)

            ayst5=log(max(1d-6,exp(yst0+ystmax)-1d0)/

     &      max(1d-6,exp(yst0+ystmin)-1d0))

            IF(ayst5.GT.1d-6) h2=h2+(ayst0/ayst5)*coef(isubsv,12)/

     &      max(1d-6,1d0-exp(-yst-yst0))

          ENDIF

          comfac=comfac*ayst0/h2

        ENDIF

      ENDIF


C...2 -> 1 processes: reduction in angular part of phase space integral

C...for case of decaying resonance

      acth0=ctnmax-ctnmin+ctpmax-ctpmin

      IF((istsb.EQ.1.OR.istsb.EQ.3.OR.istsb.EQ.5)) THEN

        IF(mdcy(pycomp(kfpr(isubsv,1)),1).EQ.1) THEN

          IF(kfpr(isub,1).EQ.25.OR.kfpr(isub,1).EQ.37.OR.

     &    kfpr(isub,1).EQ.39) THEN

            comfac=comfac*0.5d0*acth0

          ELSE

            comfac=comfac*0.125d0*(3d0*acth0+ctnmax**3-ctnmin**3+

     &      ctpmax**3-ctpmin**3)

          ENDIF

        ENDIF


C...2 -> 2 processes: angular part of phase space integral

      ELSEIF(istsb.EQ.2.OR.istsb.EQ.4) THEN

        acth1=log((max(rm34,rsqm-ctnmin)*max(rm34,rsqm-ctpmin))/

     &  (max(rm34,rsqm-ctnmax)*max(rm34,rsqm-ctpmax)))

        acth2=log((max(rm34,rsqm+ctnmax)*max(rm34,rsqm+ctpmax))/

     &  (max(rm34,rsqm+ctnmin)*max(rm34,rsqm+ctpmin)))

        acth3=1d0/max(rm34,rsqm-ctnmax)-1d0/max(rm34,rsqm-ctnmin)+

     &  1d0/max(rm34,rsqm-ctpmax)-1d0/max(rm34,rsqm-ctpmin)

        acth4=1d0/max(rm34,rsqm+ctnmin)-1d0/max(rm34,rsqm+ctnmax)+

     &  1d0/max(rm34,rsqm+ctpmin)-1d0/max(rm34,rsqm+ctpmax)

        h3=coef(isubsv,13)+

     &  (acth0/acth1)*coef(isubsv,14)/max(rm34,rsqm-cth)+

     &  (acth0/acth2)*coef(isubsv,15)/max(rm34,rsqm+cth)+

     &  (acth0/acth3)*coef(isubsv,16)/max(rm34,rsqm-cth)**2+

     &  (acth0/acth4)*coef(isubsv,17)/max(rm34,rsqm+cth)**2

        comfac=comfac*acth0*0.5d0*be34/h3


C...2 -> 2 processes: take into account final state Breit-Wigners

        comfac=comfac*vint(80)

      ENDIF


C...2 -> 3, 4 processes: phace space integral in tau'

      IF(mint(47).GE.2.AND.istsb.GE.3.AND.istsb.LE.5) THEN

        ataup1=log(taupmx/taupmn)

        ataup2=((1d0-tau/taupmx)**4-(1d0-tau/taupmn)**4)/(4d0*tau)

        h4=coef(isubsv,18)+

     &  (ataup1/ataup2)*coef(isubsv,19)*(1d0-tau/taup)**3/taup

        IF(mint(47).EQ.5) THEN

          ataup3=log(max(2d-6,1d0-taupmn)/max(2d-6,1d0-taupmx))

          h4=h4+(ataup1/ataup3)*coef(isubsv,20)*taup/max(2d-6,1d0-taup)

        ENDIF

        comfac=comfac*ataup1/h4

      ENDIF


C...2 -> 3, 4 processes: effective W/Z parton distributions

      IF(istsb.EQ.3.OR.istsb.EQ.4) THEN

        IF(1d0-tau/taup.GT.1.d-4) THEN

          fzw=(1d0+tau/taup)*log(taup/tau)-2d0*(1d0-tau/taup)

        ELSE

          fzw=1d0/6d0*(1d0-tau/taup)**3*tau/taup

        ENDIF

        comfac=comfac*fzw

      ENDIF


C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror

      IF(istsb.EQ.5) THEN

        comfac=comfac*vint(205)*vint(210)*vint(212)*vint(214)/

     &  (128d0*paru(1)**4*vint(220))*(tau**2/taup)

      ENDIF


C...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2

      IF(mstp(85).EQ.1.AND.mod(istsb,2).EQ.0) comfac=comfac*

     &sqpth**2/(parp(82)**2+sqpth)**2


C...gamma + gamma: include factor 2 when different nature

      IF(mint(11).EQ.22.AND.mint(12).EQ.22.AND.mint(123).GE.4)

     &comfac=2d0*comfac


C...Phase space integral for low-pT and multiple interactions

      IF(istsb.EQ.9) THEN

        comfac=paru(1)*paru(5)*fack*0.5d0*vint(2)/sh2

        atau1=log(2d0*(1d0+sqrt(1d0-xt2))/xt2-1d0)

        atau2=2d0*atan(1d0/xt2-1d0)/sqrt(xt2)

        h1=coef(isubsv,1)+(atau1/atau2)*coef(isubsv,2)/sqrt(tau)

        comfac=comfac*atau1/h1

        ayst0=ystmax-ystmin

        ayst1=0.5d0*(ystmax-ystmin)**2

        ayst3=2d0*(atan(exp(ystmax))-atan(exp(ystmin)))

        h2=(ayst0/ayst1)*coef(isubsv,8)*(yst-ystmin)+

     &  (ayst0/ayst1)*coef(isubsv,9)*(ystmax-yst)+

     &  (ayst0/ayst3)*coef(isubsv,10)/cosh(yst)

        comfac=comfac*ayst0/h2

        IF(mstp(82).LE.1) comfac=comfac*xt2**2*(1d0/vint(149)-1d0)

C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is

C...introduced to make cross-section finite for xT2 -> 0

        IF(mstp(82).GE.2) comfac=comfac*xt2**2/(vint(149)*

     &  (1d0+vint(149)))

      ENDIF


C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

      IF((mstp(46).GE.3.AND.mstp(46).LE.6).AND.(isub.EQ.71.OR.isub.EQ.

     &72.OR.isub.EQ.73.OR.isub.EQ.76.OR.isub.EQ.77)) THEN

C...Calculate M_R and N_R functions for Higgs-like and QCD-like models

        IF(mstp(46).LE.4) THEN

          hdtlh=log(pmas(25,1)/parp(44))

          hdtmr=(4.5d0*paru(1)/sqrt(3d0)-74d0/9d0)/8d0+hdtlh/12d0

          hdtnr=-1d0/18d0+hdtlh/6d0

        ELSE

          hdtnm=0.125d0*(1d0/(288d0*paru(1)**2)+(parp(47)/parp(45))**2)

          hdtlq=log(parp(45)/parp(44))

          hdtmr=-(4d0*paru(1))**2*0.5d0*hdtnm+hdtlq/12d0

          hdtnr=(4d0*paru(1))**2*hdtnm+hdtlq/6d0

        ENDIF


C...Calculate lowest and next-to-lowest order partial wave amplitudes

        hdtv=1d0/(16d0*paru(1)*parp(47)**2)

        a00l=sngl(hdtv*sh)

        a20l=-0.5*a00l

        a11l=a00l/6.

        hdtls=log(sh/parp(44)**2)

        a004=sngl((hdtv*sh)**2/(4d0*paru(1)))*

     &  cmplx(sngl((176d0*hdtmr+112d0*hdtnr)/3d0+11d0/27d0-

     &  (50d0/9d0)*hdtls),sngl(4d0*paru(1)))

        a204=sngl((hdtv*sh)**2/(4d0*paru(1)))*

     &  cmplx(sngl(32d0*(hdtmr+2d0*hdtnr)/3d0+25d0/54d0-

     &  (20d0/9d0)*hdtls),sngl(paru(1)))

        a114=sngl((hdtv*sh)**2/(6d0*paru(1)))*

     &  cmplx(sngl(4d0*(-2d0*hdtmr+hdtnr)-1d0/18d0),sngl(paru(1)/6d0))


C...Unitarize partial wave amplitudes with Pade or K-matrix method

        IF(mstp(46).EQ.3.OR.mstp(46).EQ.5) THEN

          a00u=a00l/(1.-a004/a00l)

          a20u=a20l/(1.-a204/a20l)

          a11u=a11l/(1.-a114/a11l)

        ELSE

          a00u=(a00l+REAL(a004))/(1.-cmplx(0.,a00l+REAL(a004)))

          a20u=(a20l+REAL(a204))/(1.-cmplx(0.,a20l+REAL(a204)))

          a11u=(a11l+REAL(a114))/(1.-cmplx(0.,a11l+REAL(a114)))

        ENDIF

      ENDIF


C...Supersymmetric processes - all of type 2 -> 2 :

C...correct final-state Breit-Wigners from fixed to running width.

      IF(isub.GE.200.AND.isub.LE.280.AND.mstp(42).GT.0) THEN

        DO 160 i=1,2

        kflw=kfpr(isubsv,i)

        kcw=pycomp(kflw)

        IF(pmas(kcw,2).LT.parp(41)) goto 160

        IF(i.EQ.1) sqmi=sqm3

        IF(i.EQ.2) sqmi=sqm4

        sqms=pmas(kcw,1)**2

        gmms=pmas(kcw,1)*pmas(kcw,2)

        hbws=gmms/((sqmi-sqms)**2+gmms**2)

        CALL pywidt(kflw,sqmi,wdtp,wdte)

        gmmi=sqrt(sqmi)*wdtp(0)

        hbwi=gmmi/((sqmi-sqms)**2+gmmi**2)

        comfac=comfac*(hbwi/hbws)

  160   CONTINUE

      ENDIF


C...A: 2 -> 1, tree diagrams


  170 IF(isub.LE.10) THEN

        IF(isub.EQ.1) THEN

C...f + fbar -> gamma*/Z0

          mint(61)=2

          CALL pywidt(23,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facz=4d0*comfac*3d0

          hp0=aem/3d0*sh

          hp1=aem/3d0*xwc*sh

          DO 180 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 180

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            hi0=hp0

            IF(iabs(i).LE.10) hi0=hi0*faca/3d0

            hi1=hp1

            IF(iabs(i).LE.10) hi1=hi1*faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facz*(ei**2/sh2*hi0*hp0*vint(111)+

     &      ei*vi*(1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*

     &      (hi0*hp1+hi1*hp0)*vint(112)+(vi**2+ai**2)/

     &      ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114))

  180     CONTINUE


        ELSEIF(isub.EQ.2) THEN

C...f + fbar' -> W+/-

          CALL pywidt(24,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmw)**2+hs**2)*3d0

          hp=aem/(24d0*xw)*sh

          DO 200 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 200

            ia=iabs(i)

            DO 190 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 190

              ja=iabs(j)

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 190

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 190

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              hi=hp*2d0

              IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))

              sigh(nchn)=hi*facbw*hf

  190       CONTINUE

  200     CONTINUE


        ELSEIF(isub.EQ.3) THEN

C...f + fbar -> h0 (or H0, or A0)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          hp=aem/(8d0*xw)*sh/sqmw*sh

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          DO 210 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 210

            ia=iabs(i)

            rmq=pmas(ia,1)**2/sh

            hi=hp*rmq

            IF(ia.LE.10) hi=hp*rmq*faca/3d0

            IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) hi=hi*

     &      (log(max(4d0,parp(37)**2*rmq*sh/paru(117)**2))/

     &      log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

            IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

              ikfi=1

              IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2

              IF(ia.GT.10) ikfi=3

              hi=hi*paru(150+10*ihigg+ikfi)**2

            ENDIF

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=hi*facbw*hf

  210     CONTINUE


        ELSEIF(isub.EQ.4) THEN

C...gamma + W+/- -> W+/-


        ELSEIF(isub.EQ.5) THEN

C...Z0 + Z0 -> h0

          CALL pywidt(25,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0

          hp=aem/(8d0*xw)*sh/sqmw*sh

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          hi=hp/4d0

          faci=8d0/(paru(1)**2*xw1)*(aem*xwc)**2

          DO 230 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 230

            DO 220 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 220

              ei=kchg(iabs(i),1)/3d0

              ai=sign(1d0,ei)

              vi=ai-4d0*ei*xwv

              ej=kchg(iabs(j),1)/3d0

              aj=sign(1d0,ej)

              vj=aj-4d0*ej*xwv

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=faci*(vi**2+ai**2)*(vj**2+aj**2)*hi*facbw*hf

  220       CONTINUE

  230     CONTINUE


        ELSEIF(isub.EQ.6) THEN

C...Z0 + W+/- -> W+/-


        ELSEIF(isub.EQ.7) THEN

C...W+ + W- -> Z0


        ELSEIF(isub.EQ.8) THEN

C...W+ + W- -> h0

          CALL pywidt(25,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(25,1)).GT.parp(48)*pmas(25,2)) facbw=0d0

          hp=aem/(8d0*xw)*sh/sqmw*sh

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          hi=hp/2d0

          faci=1d0/(4d0*paru(1)**2)*(aem/xw)**2

          DO 250 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 250

            ei=sign(1d0,dble(i))*kchg(iabs(i),1)

            DO 240 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 240

              ej=sign(1d0,dble(j))*kchg(iabs(j),1)

              IF(ei*ej.GT.0d0) goto 240

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=faci*vint(180+i)*vint(180+j)*hi*facbw*hf

  240       CONTINUE

  250     CONTINUE


C...B: 2 -> 2, tree diagrams


        ELSEIF(isub.EQ.10) THEN

C...f + f' -> f + f' (gamma/Z/W exchange)

          facggf=comfac*aem**2*2d0*(sh2+uh2)/th2

          facgzf=comfac*aem**2*xwc*4d0*sh2/(th*(th-sqmz))

          faczzf=comfac*(aem*xwc)**2*2d0*sh2/(th-sqmz)**2

          facwwf=comfac*(0.5d0*aem/xw)**2*sh2/(th-sqmw)**2

          DO 270 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 270

            ia=iabs(i)

            DO 260 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 260

              ja=iabs(j)

C...Electroweak couplings

              ei=kchg(ia,1)*isign(1,i)/3d0

              ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)

              vi=ai-4d0*ei*xwv

              ej=kchg(ja,1)*isign(1,j)/3d0

              aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)

              vj=aj-4d0*ej*xwv

              epsij=isign(1,i*j)

C...gamma/Z exchange, only gamma exchange, or only Z exchange

              IF(mstp(21).GE.1.AND.mstp(21).LE.4) THEN

                IF(mstp(21).EQ.1.OR.mstp(21).EQ.4) THEN

                  facncf=facggf*ei**2*ej**2+facgzf*ei*ej*

     &            (vi*vj*(1d0+uh2/sh2)+ai*aj*epsij*(1d0-uh2/sh2))+

     &            faczzf*((vi**2+ai**2)*(vj**2+aj**2)*(1d0+uh2/sh2)+

     &            4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))

                ELSEIF(mstp(21).EQ.2) THEN

                  facncf=facggf*ei**2*ej**2

                ELSE

                  facncf=faczzf*((vi**2+ai**2)*(vj**2+aj**2)*

     &            (1d0+uh2/sh2)+4d0*vi*vj*ai*aj*epsij*(1d0-uh2/sh2))

                ENDIF

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                sigh(nchn)=facncf

              ENDIF

C...W exchange

              IF((mstp(21).EQ.1.OR.mstp(21).EQ.5).AND.ai*aj.LT.0d0) THEN

                facccf=facwwf*vint(180+i)*vint(180+j)

                IF(epsij.LT.0d0) facccf=facccf*uh2/sh2

                IF(ia.GT.10.AND.mod(ia,2).EQ.0) facccf=2d0*facccf

                IF(ja.GT.10.AND.mod(ja,2).EQ.0) facccf=2d0*facccf

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                sigh(nchn)=facccf

              ENDIF

  260       CONTINUE

  270     CONTINUE

        ENDIF


      ELSEIF(isub.LE.20) THEN

        IF(isub.EQ.11) THEN

C...f + f' -> f + f' (g exchange)

          facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2

          facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-

     &    mstp(34)*2d0/3d0*uh2/(sh*th))

          facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-

     &    mstp(34)*2d0/3d0*sh2/(th*uh))

          IF(mstp(5).GE.1) THEN

C...Modifications from contact interactions (compositeness)

            facci1=facqq1+comfac*(sh2/paru(155)**4)

            faccib=facqqb+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*

     &      (uh2/th+uh2/sh)+comfac*(5d0/3d0)*(uh2/paru(155)**4)

            facci2=facqq2+comfac*(8d0/9d0)*(as*paru(156)/paru(155)**2)*

     &      (sh2/th+sh2/uh)+comfac*(5d0/3d0)*(sh2/paru(155)**4)

            facci3=facqq1+comfac*(uh2/paru(155)**4)

          ENDIF

          DO 290 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 290

            DO 280 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 280

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.(ia.GE.3.OR.

     &        ja.GE.3))) THEN

                sigh(nchn)=facqq1

                IF(i.EQ.-j) sigh(nchn)=facqqb

              ELSE

                sigh(nchn)=facci1

                IF(i*j.LT.0) sigh(nchn)=facci3

                IF(i.EQ.-j) sigh(nchn)=faccib

              ENDIF

              IF(i.EQ.j) THEN

                sigh(nchn)=0.5d0*sigh(nchn)

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.ia.GE.3)) THEN

                  sigh(nchn)=0.5d0*facqq2

                ELSE

                  sigh(nchn)=0.5d0*facci2

                ENDIF

              ENDIF

  280       CONTINUE

  290     CONTINUE


        ELSEIF(isub.EQ.12) THEN

C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)

          CALL pywidt(21,sh,wdtp,wdte)

          facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*

     &    (wdte(0,1)+wdte(0,2)+wdte(0,4))

          IF(mstp(5).EQ.1) THEN

C...Modifications from contact interactions (compositeness)

            faccib=facqqb

            DO 300 i=1,2

              faccib=faccib+comfac*(uh2/paru(155)**4)*(wdte(i,1)+

     &        wdte(i,2)+wdte(i,4))

  300       CONTINUE

          ELSEIF(mstp(5).GE.2) THEN

            faccib=facqqb+comfac*(uh2/paru(155)**4)*

     &      (wdte(0,1)+wdte(0,2)+wdte(0,4))

          ENDIF

          DO 310 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 310

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            IF(mstp(5).LE.0.OR.(mstp(5).EQ.1.AND.iabs(i).GE.3)) THEN

              sigh(nchn)=facqqb

            ELSE

              sigh(nchn)=faccib

            ENDIF

  310     CONTINUE


        ELSEIF(isub.EQ.13) THEN

C...f + fbar -> g + g (q + qbar -> g + g only)

          facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*

     &    uh2/sh2)

          facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*

     &    th2/sh2)

          DO 320 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 320

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=0.5d0*facgg1

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=2

            sigh(nchn)=0.5d0*facgg2

  320     CONTINUE


        ELSEIF(isub.EQ.14) THEN

C...f + fbar -> g + gamma (q + qbar -> g + gamma only)

          facgg=comfac*as*aem*8d0/9d0*(th2+uh2)/(th*uh)

          DO 330 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 330

            ei=kchg(iabs(i),1)/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facgg*ei**2

  330     CONTINUE


        ELSEIF(isub.EQ.15) THEN

C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)

          faczg=comfac*as*aem*(8d0/9d0)*(th2+uh2+2d0*sqm4*sh)/(th*uh)

C...gamma, gamma/Z interference and Z couplings to final fermion pairs

          hfgg=0d0

          hfgz=0d0

          hfzz=0d0

          radc4=1d0+pyalps(sqm4)/paru(1)

          DO 340 i=1,min(16,mdcy(23,3))

            idc=i+mdcy(23,2)-1

            IF(mdme(idc,1).LT.0) goto 340

            imdm=0

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)

     &      imdm=1

            IF(i.LE.8) THEN

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ELSEIF(i.LE.16) THEN

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc4

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.EQ.1) THEN

                hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34

                hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

  340     CONTINUE

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)

          mint(15)=1

          mint(61)=1

          CALL pywidt(23,sqm4,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          hfgg=hfgg*hfaem*vint(111)/sqm4

          hfgz=hfgz*hfaem*vint(112)/sqm4

          hfzz=hfzz*hfaem*vint(114)/sqm4

C...Loop over flavours; consider full gamma/Z structure

          DO 350 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 350

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=faczg*(ei**2*hfgg+ei*vi*hfgz+

     &      (vi**2+ai**2)*hfzz)/hbw4

  350     CONTINUE


        ELSEIF(isub.EQ.16) THEN

C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)

          facwg=comfac*as*aem/xw*2d0/9d0*(th2+uh2+2d0*sqm4*sh)/(th*uh)

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm4,wdtp,wdte)

          gmmwc=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)

          facwg=facwg*hbw4c/hbw4

          DO 370 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 370

            DO 360 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 360

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 360

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)

              fckm=vckm((ia+1)/2,(ja+1)/2)

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facwg*fckm*widsc

  360       CONTINUE

  370     CONTINUE


        ELSEIF(isub.EQ.17) THEN

C...f + fbar -> g + h0 (q + qbar -> g + h0 only)


        ELSEIF(isub.EQ.18) THEN

C...f + fbar -> gamma + gamma

          facgg=comfac*aem**2*2d0*(th2+uh2)/(th*uh)

          DO 380 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 380

            ei=kchg(iabs(i),1)/3d0

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=0.5d0*facgg*fcoi*ei**4

  380     CONTINUE


        ELSEIF(isub.EQ.19) THEN

C...f + fbar -> gamma + (gamma*/Z0)

          facgz=comfac*2d0*aem**2*(th2+uh2+2d0*sqm4*sh)/(th*uh)

C...gamma, gamma/Z interference and Z couplings to final fermion pairs

          hfgg=0d0

          hfgz=0d0

          hfzz=0d0

          radc4=1d0+pyalps(sqm4)/paru(1)

          DO 390 i=1,min(16,mdcy(23,3))

            idc=i+mdcy(23,2)-1

            IF(mdme(idc,1).LT.0) goto 390

            imdm=0

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)

     &      imdm=1

            IF(i.LE.8) THEN

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ELSEIF(i.LE.16) THEN

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc4

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.EQ.1) THEN

                hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34

                hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

  390     CONTINUE

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)

          mint(15)=1

          mint(61)=1

          CALL pywidt(23,sqm4,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          hfgg=hfgg*hfaem*vint(111)/sqm4

          hfgz=hfgz*hfaem*vint(112)/sqm4

          hfzz=hfzz*hfaem*vint(114)/sqm4

C...Loop over flavours; consider full gamma/Z structure

          DO 400 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 400

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facgz*fcoi*ei**2*(ei**2*hfgg+ei*vi*hfgz+

     &      (vi**2+ai**2)*hfzz)/hbw4

  400     CONTINUE


        ELSEIF(isub.EQ.20) THEN

C...f + fbar' -> gamma + W+/-

          facgw=comfac*0.5d0*aem**2/xw

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm4,wdtp,wdte)

          gmmwc=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)

          facgw=facgw*hbw4c/hbw4

C...Anomalous couplings

          term1=(th2+uh2+2d0*sqm4*sh)/(th*uh)

          term2=0d0

          term3=0d0

          IF(mstp(5).GE.1) THEN

            term2=paru(153)*(th-uh)/(th+uh)

            term3=0.5d0*paru(153)**2*(th*uh+(th2+uh2)*sh/

     &      (4d0*sqmw))/(th+uh)**2

          ENDIF

          DO 420 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 420

            DO 410 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 410

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 410

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 410

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)

              IF(ia.LE.10) THEN

                facwr=uh/(th+uh)-1d0/3d0

                fckm=vckm((ia+1)/2,(ja+1)/2)

                fcoi=faca/3d0

              ELSE

                facwr=-th/(th+uh)

                fckm=1d0

                fcoi=1d0

              ENDIF

              facwk=term1*facwr**2+term2*facwr+term3

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facgw*facwk*fcoi*fckm*widsc

  410       CONTINUE

  420     CONTINUE

        ENDIF


      ELSEIF(isub.LE.30) THEN

        IF(isub.EQ.21) THEN

C...f + fbar -> gamma + h0


        ELSEIF(isub.EQ.22) THEN

C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)

C...Kinematics dependence

          faczz=comfac*aem**2*((th2+uh2+2d0*(sqm3+sqm4)*sh)/(th*uh)-

     &    sqm3*sqm4*(1d0/th2+1d0/uh2))

C...gamma, gamma/Z interference and Z couplings to final fermion pairs

          DO 440 i=1,6

            DO 430 j=1,3

              hgz(i,j)=0d0

  430       CONTINUE

  440     CONTINUE

          radc3=1d0+pyalps(sqm3)/paru(1)

          radc4=1d0+pyalps(sqm4)/paru(1)

          DO 450 i=1,min(16,mdcy(23,3))

            idc=i+mdcy(23,2)-1

            IF(mdme(idc,1).LT.0) goto 450

            imdm=0

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2) imdm=1

            IF(mdme(idc,1).EQ.4.OR.mdme(idc,1).EQ.5) imdm=mdme(idc,1)-2

            IF(i.LE.8) THEN

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ELSEIF(i.LE.16) THEN

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm3

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc3

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.GE.1) THEN

                hgz(1,imdm)=hgz(1,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34

                hgz(2,imdm)=hgz(2,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hgz(3,imdm)=hgz(3,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc4

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.GE.1) THEN

                hgz(4,imdm)=hgz(4,imdm)+fcof*ef**2*(1d0+2d0*rm1)*be34

                hgz(5,imdm)=hgz(5,imdm)+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hgz(6,imdm)=hgz(6,imdm)+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

  450     CONTINUE

C...Propagators: as simulated in PYOFSH and as desired

          hbw3=(1d0/paru(1))*gmmz/((sqm3-sqmz)**2+gmmz**2)

          hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)

          mint(15)=1

          mint(61)=1

          CALL pywidt(23,sqm3,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          DO 460 j=1,3

            hgz(1,j)=hgz(1,j)*hfaem*vint(111)/sqm3

            hgz(2,j)=hgz(2,j)*hfaem*vint(112)/sqm3

            hgz(3,j)=hgz(3,j)*hfaem*vint(114)/sqm3

  460     CONTINUE

          mint(61)=1

          CALL pywidt(23,sqm4,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          DO 470 j=1,3

            hgz(4,j)=hgz(4,j)*hfaem*vint(111)/sqm4

            hgz(5,j)=hgz(5,j)*hfaem*vint(112)/sqm4

            hgz(6,j)=hgz(6,j)*hfaem*vint(114)/sqm4

  470     CONTINUE

C...Loop over flavours; separate left- and right-handed couplings

          DO 490 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 490

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            vali=vi-ai

            vari=vi+ai

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            DO 480 j=1,3

              hl3(j)=ei**2*hgz(1,j)+ei*vali*hgz(2,j)+vali**2*hgz(3,j)

              hr3(j)=ei**2*hgz(1,j)+ei*vari*hgz(2,j)+vari**2*hgz(3,j)

              hl4(j)=ei**2*hgz(4,j)+ei*vali*hgz(5,j)+vali**2*hgz(6,j)

              hr4(j)=ei**2*hgz(4,j)+ei*vari*hgz(5,j)+vari**2*hgz(6,j)

  480       CONTINUE

            faclr=hl3(1)*hl4(1)+hl3(1)*(hl4(2)+hl4(3))+

     &      hl4(1)*(hl3(2)+hl3(3))+hl3(2)*hl4(3)+hl4(2)*hl3(3)+

     &      hr3(1)*hr4(1)+hr3(1)*(hr4(2)+hr4(3))+

     &      hr4(1)*(hr3(2)+hr3(3))+hr3(2)*hr4(3)+hr4(2)*hr3(3)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=0.5d0*faczz*fcoi*faclr/(hbw3*hbw4)

  490     CONTINUE


        ELSEIF(isub.EQ.23) THEN

C...f + fbar' -> Z0 + W+/-

          faczw=comfac*0.5d0*(aem/xw)**2

          faczw=faczw*wids(23,2)

          thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)

          facbw=1d0/((sh-sqmw)**2+gmmw**2)

          DO 510 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 510

            DO 500 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 500

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 500

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 500

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              ei=kchg(ia,1)/3d0

              ai=sign(1d0,ei+0.1d0)

              vi=ai-4d0*ei*xwv

              ej=kchg(ja,1)/3d0

              aj=sign(1d0,ej+0.1d0)

              vj=aj-4d0*ej*xwv

              IF(vi+ai.GT.0) THEN

                visav=vi

                aisav=ai

                vi=vj

                ai=aj

                vj=visav

                aj=aisav

              ENDIF

              fckm=1d0

              IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)

              fcoi=1d0

              IF(ia.LE.10) fcoi=faca/3d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=faczw*fcoi*fckm*(facbw*((9d0-8d0*xw)/4d0*thuh+

     &        (8d0*xw-6d0)/4d0*sh*(sqm3+sqm4))+(thuh-sh*(sqm3+sqm4))*

     &        (sh-sqmw)*facbw*0.5d0*((vj+aj)/th-(vi+ai)/uh)+

     &        thuh/(16d0*xw1)*((vj+aj)**2/th2+(vi+ai)**2/uh2)+

     &        sh*(sqm3+sqm4)/(8d0*xw1)*(vi+ai)*(vj+aj)/(th*uh))*

     &        wids(24,(5-kchw)/2)

  500       CONTINUE

  510     CONTINUE


        ELSEIF(isub.EQ.24) THEN

C...f + fbar -> Z0 + h0 (or H0, or A0)

          thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)

          fachz=comfac*8d0*(aem*xwc)**2*

     &    (thuh+2d0*sh*sqm3)/((sh-sqmz)**2+gmmz**2)

          fachz=fachz*wids(23,2)*wids(kfhigg,2)

          IF(mstp(4).GE.1.OR.ihigg.GE.2) fachz=fachz*

     &    paru(154+10*ihigg)**2

          DO 520 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 520

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=fachz*fcoi*(vi**2+ai**2)

  520     CONTINUE


        ELSEIF(isub.EQ.25) THEN

C...f + fbar -> W+ + W-

C...Propagators: Z0, W+- as simulated in PYOFSH and as desired

          CALL pywidt(23,sh,wdtp,wdte)

          gmmzc=shr*wdtp(0)

          hbwzc=sh**2/((sh-sqmz)**2+gmmzc**2)

          hbw3=gmmw/((sqm3-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm3,wdtp,wdte)

          gmmw3=sqrt(sqm3)*wdtp(0)

          hbw3c=gmmw3/((sqm3-sqmw)**2+gmmw3**2)

          hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm4,wdtp,wdte)

          gmmw4=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmw4/((sqm4-sqmw)**2+gmmw4**2)

C...Kinematical functions

          thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)

          thuh34=(2d0*sh*(sqm3+sqm4)+thuh)/(sqm3*sqm4)

          gs=(((sh-sqm3-sqm4)**2-4d0*sqm3*sqm4)*thuh34+12d0*thuh)/sh2

          gt=thuh34+4d0*thuh/th2

          gst=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/th)/sh

          gu=thuh34+4d0*thuh/uh2

          gsu=((sh-sqm3-sqm4)*thuh34+4d0*(sh*(sqm3+sqm4)-thuh)/uh)/sh

C...Common factors and couplings

          facww=comfac*(hbw3c/hbw3)*(hbw4c/hbw4)

          facww=facww*wids(24,1)

          cgg=aem**2/2d0

          cgz=aem**2/(4d0*xw)*hbwzc*(1d0-sqmz/sh)

          czz=aem**2/(32d0*xw**2)*hbwzc

          cng=aem**2/(4d0*xw)

          cnz=aem**2/(16d0*xw**2)*hbwzc*(1d0-sqmz/sh)

          cnn=aem**2/(16d0*xw**2)

C...Coulomb factor for W+W- pair

          IF(mstp(40).GE.1.AND.mstp(40).LE.3) THEN

            coule=(sh-4d0*sqmw)/(4d0*pmas(24,1))

            coulp=max(1d-10,0.5d0*be34*sqrt(sh))

            IF(coule.LT.100d0*pmas(24,2)) THEN

              coulp1=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+

     &        pmas(24,2)**2)-coule))

            ELSE

              coulp1=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/coule))

            ENDIF

            IF(coule.GT.-100d0*pmas(24,2)) THEN

              coulp2=sqrt(0.5d0*pmas(24,1)*(sqrt(coule**2+

     &        pmas(24,2)**2)+coule))

            ELSE

              coulp2=sqrt(0.5d0*pmas(24,1)*(0.5d0*pmas(24,2)**2/

     &        abs(coule)))

            ENDIF

            IF(mstp(40).EQ.1) THEN

              couldc=paru(1)-2d0*atan((coulp1**2+coulp2**2-coulp**2)/

     &        max(1d-10,2d0*coulp*coulp1))

              faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)

            ELSEIF(mstp(40).EQ.2) THEN

              coulck=cmplx(sngl(coulp1),sngl(coulp2))

              coulcp=cmplx(0.,sngl(coulp))

              coulcd=(coulck+coulcp)/(coulck-coulcp)

              coulcr=1.+sngl(paru(101)*sqrt(sh))/(4.*coulcp)*log(coulcd)

              coulcs=cmplx(0.,0.)

              nstp=100

              DO 530 istp=1,nstp

                coulxx=(istp-0.5)/nstp

                coulcs=coulcs+(1./coulxx)*log((1.+coulxx*coulcd)/

     &          (1.+coulxx/coulcd))

  530         CONTINUE

              coulcr=coulcr+sngl(paru(101)**2*sh)/(16.*coulcp*coulck)*

     &        (coulcs/nstp)

              faccou=abs(coulcr)**2

            ELSEIF(mstp(40).EQ.3) THEN

              couldc=paru(1)-2d0*(1d0-be34)**2*atan((coulp1**2+

     &        coulp2**2-coulp**2)/max(1d-10,2d0*coulp*coulp1))

              faccou=1d0+0.5d0*paru(101)*couldc/max(1d-5,be34)

            ENDIF

          ELSEIF(mstp(40).EQ.4) THEN

            faccou=1d0+0.5d0*paru(101)*paru(1)/max(1d-5,be34)

          ELSE

            faccou=1d0

          ENDIF

          vint(95)=faccou

          facww=facww*faccou

C...Loop over allowed flavours

          DO 540 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 540

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            IF(ai.LT.0d0) THEN

              dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs+

     &        (cng*ei+cnz*(vi+ai))*gst+cnn*gt

            ELSE

              dsigww=(cgg*ei**2+cgz*vi*ei+czz*(vi**2+ai**2))*gs-

     &        (cng*ei+cnz*(vi+ai))*gsu+cnn*gu

            ENDIF

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facww*fcoi*dsigww

  540     CONTINUE


        ELSEIF(isub.EQ.26) THEN

C...f + fbar' -> W+/- + h0 (or H0, or A0)

          thuh=max(th*uh-sqm3*sqm4,sh*ckin(3)**2)

          fachw=comfac*0.125d0*(aem/xw)**2*(thuh+2d0*sh*sqm3)/

     &    ((sh-sqmw)**2+gmmw**2)

          fachw=fachw*wids(kfhigg,2)

          IF(mstp(4).GE.1.OR.ihigg.GE.2) fachw=fachw*

     &    paru(155+10*ihigg)**2

          DO 560 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 560

            DO 550 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.20.OR.kfac(1,j).EQ.0) goto 550

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 550

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 550

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              fckm=1d0

              IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)

              fcoi=1d0

              IF(ia.LE.10) fcoi=faca/3d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=fachw*fcoi*fckm*wids(24,(5-kchw)/2)

  550       CONTINUE

  560     CONTINUE


        ELSEIF(isub.EQ.27) THEN

C...f + fbar -> h0 + h0


        ELSEIF(isub.EQ.28) THEN

C...f + g -> f + g (q + g -> q + g only)

          facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-

     &    uh/sh)*faca

          facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-

     &    sh/uh)

          DO 580 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.10) goto 580

            DO 570 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 570

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 570

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=facqg1

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=2

              sigh(nchn)=facqg2

  570       CONTINUE

  580     CONTINUE


        ELSEIF(isub.EQ.29) THEN

C...f + g -> f + gamma (q + g -> q + gamma only)

          fgq=comfac*faca*as*aem*1d0/3d0*(sh2+uh2)/(-sh*uh)

          DO 600 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 600

            ei=kchg(iabs(i),1)/3d0

            facgq=fgq*ei**2

            DO 590 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 590

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 590

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=facgq

  590       CONTINUE

  600     CONTINUE


        ELSEIF(isub.EQ.30) THEN

C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)

          fzq=comfac*faca*as*aem*(1d0/3d0)*(sh2+uh2+2d0*sqm4*th)/

     &    (-sh*uh)

C...gamma, gamma/Z interference and Z couplings to final fermion pairs

          hfgg=0d0

          hfgz=0d0

          hfzz=0d0

          radc4=1d0+pyalps(sqm4)/paru(1)

          DO 610 i=1,min(16,mdcy(23,3))

            idc=i+mdcy(23,2)-1

            IF(mdme(idc,1).LT.0) goto 610

            imdm=0

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)

     &      imdm=1

            IF(i.LE.8) THEN

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ELSEIF(i.LE.16) THEN

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc4

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.EQ.1) THEN

                hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34

                hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

  610     CONTINUE

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)

          mint(15)=1

          mint(61)=1

          CALL pywidt(23,sqm4,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          hfgg=hfgg*hfaem*vint(111)/sqm4

          hfgz=hfgz*hfaem*vint(112)/sqm4

          hfzz=hfzz*hfaem*vint(114)/sqm4

C...Loop over flavours; consider full gamma/Z structure

          DO 630 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 630

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            faczq=fzq*(ei**2*hfgg+ei*vi*hfgz+

     &      (vi**2+ai**2)*hfzz)/hbw4

            DO 620 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 620

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 620

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=faczq

  620       CONTINUE

  630     CONTINUE

        ENDIF


      ELSEIF(isub.LE.40) THEN

        IF(isub.EQ.31) THEN

C...f + g -> f' + W+/- (q + g -> q' + W+/- only)

          facwq=comfac*faca*as*aem/xw*1d0/12d0*

     &    (sh2+uh2+2d0*sqm4*th)/(-sh*uh)

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm4,wdtp,wdte)

          gmmwc=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)

          facwq=facwq*hbw4c/hbw4

          DO 650 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 650

            ia=iabs(i)

            kchw=isign(1,kchg(ia,1)*isign(1,i))

            widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)

            DO 640 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 640

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 640

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=facwq*vint(180+i)*widsc

  640       CONTINUE

  650     CONTINUE


        ELSEIF(isub.EQ.32) THEN

C...f + g -> f + h0 (q + g -> q + h0 only)


        ELSEIF(isub.EQ.33) THEN

C...f + gamma -> f + g (q + gamma -> q + g only)

          fgq=comfac*as*aem*8d0/3d0*(sh2+uh2)/(-sh*uh)

          DO 670 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 670

            ei=kchg(iabs(i),1)/3d0

            facgq=fgq*ei**2

            DO 660 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 660

              IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 660

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=22

              isig(nchn,3)=1

              sigh(nchn)=facgq

  660       CONTINUE

  670     CONTINUE


        ELSEIF(isub.EQ.34) THEN

C...f + gamma -> f + gamma

          fgq=comfac*aem**2*2d0*(sh2+uh2)/(-sh*uh)

          DO 690 i=mmina,mmaxa

            IF(i.EQ.0) goto 690

            ei=kchg(iabs(i),1)/3d0

            facgq=fgq*ei**4

            DO 680 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 680

              IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 680

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=22

              isig(nchn,3)=1

              sigh(nchn)=facgq

  680       CONTINUE

  690     CONTINUE


        ELSEIF(isub.EQ.35) THEN

C...f + gamma -> f + (gamma*/Z0)

          fzqn=comfac*2d0*aem**2*(sh2+uh2+2d0*sqm4*th)

          fzqd=sqpth*sqm4-sh*uh

C...gamma, gamma/Z interference and Z couplings to final fermion pairs

          hfgg=0d0

          hfgz=0d0

          hfzz=0d0

          radc4=1d0+pyalps(sqm4)/paru(1)

          DO 700 i=1,min(16,mdcy(23,3))

            idc=i+mdcy(23,2)-1

            IF(mdme(idc,1).LT.0) goto 700

            imdm=0

            IF(mdme(idc,1).EQ.1.OR.mdme(idc,1).EQ.2.OR.mdme(idc,1).EQ.4)

     &      imdm=1

            IF(i.LE.8) THEN

              ef=kchg(i,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ELSEIF(i.LE.16) THEN

              ef=kchg(i+2,1)/3d0

              af=sign(1d0,ef+0.1d0)

              vf=af-4d0*ef*xwv

            ENDIF

            rm1=pmas(iabs(kfdp(idc,1)),1)**2/sqm4

            IF(4d0*rm1.LT.1d0) THEN

              fcof=1d0

              IF(i.LE.8) fcof=3d0*radc4

              be34=sqrt(max(0d0,1d0-4d0*rm1))

              IF(imdm.EQ.1) THEN

                hfgg=hfgg+fcof*ef**2*(1d0+2d0*rm1)*be34

                hfgz=hfgz+fcof*ef*vf*(1d0+2d0*rm1)*be34

                hfzz=hfzz+fcof*(vf**2*(1d0+2d0*rm1)+

     &          af**2*(1d0-4d0*rm1))*be34

              ENDIF

            ENDIF

  700     CONTINUE

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=(1d0/paru(1))*gmmz/((sqm4-sqmz)**2+gmmz**2)

          mint(15)=1

          mint(61)=1

          CALL pywidt(23,sqm4,wdtp,wdte)

          hfaem=(paru(108)/paru(2))*(2d0/3d0)

          hfgg=hfgg*hfaem*vint(111)/sqm4

          hfgz=hfgz*hfaem*vint(112)/sqm4

          hfzz=hfzz*hfaem*vint(114)/sqm4

C...Loop over flavours; consider full gamma/Z structure

          DO 720 i=mmina,mmaxa

            IF(i.EQ.0) goto 720

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            faczq=ei**2*(ei**2*hfgg+ei*vi*hfgz+

     &      (vi**2+ai**2)*hfzz)/hbw4

            DO 710 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 710

              IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 710

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=22

              isig(nchn,3)=1

              sigh(nchn)=faczq*fzqn/max(pmas(iabs(i),1)**2*sqm4,fzqd)

  710       CONTINUE

  720     CONTINUE


        ELSEIF(isub.EQ.36) THEN

C...f + gamma -> f' + W+/-

          fwq=comfac*aem**2/(2d0*xw)*

     &    (sh2+uh2+2d0*sqm4*th)/(sqpth*sqm4-sh*uh)

C...Propagators: as simulated in PYOFSH and as desired

          hbw4=gmmw/((sqm4-sqmw)**2+gmmw**2)

          CALL pywidt(24,sqm4,wdtp,wdte)

          gmmwc=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmwc/((sqm4-sqmw)**2+gmmwc**2)

          fwq=fwq*hbw4c/hbw4

          DO 740 i=mmina,mmaxa

            IF(i.EQ.0) goto 740

            ia=iabs(i)

            eia=abs(kchg(iabs(i),1)/3d0)

            facwq=fwq*(eia-sh/(sh+uh))**2

            kchw=isign(1,kchg(ia,1)*isign(1,i))

            widsc=(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))/wdtp(0)

            DO 730 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 730

              IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 730

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=22

              isig(nchn,3)=1

              sigh(nchn)=facwq*vint(180+i)*widsc

  730       CONTINUE

  740     CONTINUE


        ELSEIF(isub.EQ.37) THEN

C...f + gamma -> f + h0


        ELSEIF(isub.EQ.38) THEN

C...f + Z0 -> f + g (q + Z0 -> q + g only)


        ELSEIF(isub.EQ.39) THEN

C...f + Z0 -> f + gamma


        ELSEIF(isub.EQ.40) THEN

C...f + Z0 -> f + Z0

        ENDIF


      ELSEIF(isub.LE.50) THEN

        IF(isub.EQ.41) THEN

C...f + Z0 -> f' + W+/-


        ELSEIF(isub.EQ.42) THEN

C...f + Z0 -> f + h0


        ELSEIF(isub.EQ.43) THEN

C...f + W+/- -> f' + g (q + W+/- -> q' + g only)


        ELSEIF(isub.EQ.44) THEN

C...f + W+/- -> f' + gamma


        ELSEIF(isub.EQ.45) THEN

C...f + W+/- -> f' + Z0


        ELSEIF(isub.EQ.46) THEN

C...f + W+/- -> f' + W+/-


        ELSEIF(isub.EQ.47) THEN

C...f + W+/- -> f' + h0


        ELSEIF(isub.EQ.48) THEN

C...f + h0 -> f + g (q + h0 -> q + g only)


        ELSEIF(isub.EQ.49) THEN

C...f + h0 -> f + gamma


        ELSEIF(isub.EQ.50) THEN

C...f + h0 -> f + Z0

        ENDIF


      ELSEIF(isub.LE.60) THEN

        IF(isub.EQ.51) THEN

C...f + h0 -> f' + W+/-


        ELSEIF(isub.EQ.52) THEN

C...f + h0 -> f + h0


        ELSEIF(isub.EQ.53) THEN

C...g + g -> f + fbar (g + g -> q + qbar only)

          CALL pywidt(21,sh,wdtp,wdte)

          facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*

     &    uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca

          facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*

     &    th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 750

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqq1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=facqq2

  750     CONTINUE


        ELSEIF(isub.EQ.54) THEN

C...g + gamma -> f + fbar (g + gamma -> q + qbar only)

          CALL pywidt(21,sh,wdtp,wdte)

          wdtesu=0d0

          DO 760 i=1,min(8,mdcy(21,3))

            ef=kchg(i,1)/3d0

            wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+

     &      wdte(i,4))

  760     CONTINUE

          facqq=comfac*aem*as*wdtesu*(th2+uh2)/(th*uh)

          IF(kfac(1,21)*kfac(2,22).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=22

            isig(nchn,3)=1

            sigh(nchn)=facqq

          ENDIF

          IF(kfac(1,22)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=22

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqq

          ENDIF


        ELSEIF(isub.EQ.55) THEN

C...g + Z -> f + fbar (g + Z -> q + qbar only)


        ELSEIF(isub.EQ.56) THEN

C...g + W -> f + f'bar (g + W -> q + q'bar only)


        ELSEIF(isub.EQ.57) THEN

C...g + h0 -> f + fbar (g + h0 -> q + qbar only)


        ELSEIF(isub.EQ.58) THEN

C...gamma + gamma -> f + fbar

          CALL pywidt(22,sh,wdtp,wdte)

          wdtesu=0d0

          DO 770 i=1,min(12,mdcy(22,3))

            IF(i.LE.8) ef= kchg(i,1)/3d0

            IF(i.GE.9) ef= kchg(9+2*(i-8),1)/3d0

            wdtesu=wdtesu+ef**2*(wdte(i,1)+wdte(i,2)+wdte(i,3)+

     &      wdte(i,4))

  770     CONTINUE

          facff=comfac*aem**2*wdtesu*2d0*(th2+uh2)/(th*uh)

          IF(kfac(1,22)*kfac(2,22).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=22

            isig(nchn,2)=22

            isig(nchn,3)=1

            sigh(nchn)=facff

          ENDIF


        ELSEIF(isub.EQ.59) THEN

C...gamma + Z0 -> f + fbar


        ELSEIF(isub.EQ.60) THEN

C...gamma + W+/- -> f + fbar'

        ENDIF


      ELSEIF(isub.LE.70) THEN

        IF(isub.EQ.61) THEN

C...gamma + h0 -> f + fbar


        ELSEIF(isub.EQ.62) THEN

C...Z0 + Z0 -> f + fbar


        ELSEIF(isub.EQ.63) THEN

C...Z0 + W+/- -> f + fbar'


        ELSEIF(isub.EQ.64) THEN

C...Z0 + h0 -> f + fbar


        ELSEIF(isub.EQ.65) THEN

C...W+ + W- -> f + fbar


        ELSEIF(isub.EQ.66) THEN

C...W+/- + h0 -> f + fbar'


        ELSEIF(isub.EQ.67) THEN

C...h0 + h0 -> f + fbar


        ELSEIF(isub.EQ.68) THEN

C...g + g -> g + g

          facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+2d0*th/sh+

     &    th2/sh2)*faca

          facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+2d0*sh/uh+

     &    sh2/uh2)*faca

          facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3d0+2d0*uh/th+

     &    uh2/th2)

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 780

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=0.5d0*facgg1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=0.5d0*facgg2

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=3

          sigh(nchn)=0.5d0*facgg3

  780     CONTINUE


        ELSEIF(isub.EQ.69) THEN

C...gamma + gamma -> W+ + W-

          sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))

          fprop=sh2/((sqmwe-th)*(sqmwe-uh))

          facww=comfac*6d0*aem**2*(1d0-fprop*(4d0/3d0+2d0*sqmwe/sh)+

     &    fprop**2*(2d0/3d0+2d0*(sqmwe/sh)**2))*wids(24,1)

          IF(kfac(1,22)*kfac(2,22).EQ.0) goto 790

          nchn=nchn+1

          isig(nchn,1)=22

          isig(nchn,2)=22

          isig(nchn,3)=1

          sigh(nchn)=facww

  790     CONTINUE


        ELSEIF(isub.EQ.70) THEN

C...gamma + W+/- -> Z0 + W+/-

          sqmwe=max(0.5d0*sqmw,sqrt(sqm3*sqm4))

          fprop=(th-sqmwe)**2/(-sh*(sqmwe-uh))

          faczw=comfac*6d0*aem**2*(xw1/xw)*

     &    (1d0-fprop*(4d0/3d0+2d0*sqmwe/(th-sqmwe))+

     &    fprop**2*(2d0/3d0+2d0*(sqmwe/(th-sqmwe))**2))*wids(23,2)

          DO 810 kchw=1,-1,-2

            DO 800 isde=1,2

              IF(kfac(isde,22)*kfac(3-isde,24*kchw).EQ.0) goto 800

              nchn=nchn+1

              isig(nchn,isde)=22

              isig(nchn,3-isde)=24*kchw

              isig(nchn,3)=1

              sigh(nchn)=faczw*wids(24,(5-kchw)/2)

  800       CONTINUE

  810     CONTINUE

        ENDIF


      ELSEIF(isub.LE.80) THEN

        IF(isub.EQ.71) THEN

C...Z0 + Z0 -> Z0 + Z0

          IF(sh.LE.4.01d0*sqmz) goto 840


          IF(mstp(46).LE.2) THEN

C...Exact scattering ME:s for on-mass-shell gauge bosons

            be2=1d0-4d0*sqmz/sh

            th=-0.5d0*sh*be2*(1d0-cth)

            uh=-0.5d0*sh*be2*(1d0+cth)

            IF(max(th,uh).GT.-1d0) goto 840

            shang=1d0/xw1*sqmw/sqmz*(1d0+be2)**2

            ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang

            ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang

            thang=1d0/xw1*sqmw/sqmz*(be2-cth)**2

            athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang

            athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang

            uhang=1d0/xw1*sqmw/sqmz*(be2+cth)**2

            auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang

            auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang

            faczz=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*

     &      (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2

            IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)

            IF(mstp(46).EQ.1) faczz=faczz*((ashre+athre+auhre)**2+

     &      (ashim+athim+auhim)**2)

            IF(mstp(46).EQ.2) faczz=0d0


          ELSE

C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

            faczz=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*

     &      abs(a00u+2.*a20u)**2

          ENDIF

          faczz=faczz*wids(23,1)


          DO 830 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 830

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            avi=ai**2+vi**2

            DO 820 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 820

              ej=kchg(iabs(j),1)/3d0

              aj=sign(1d0,ej)

              vj=aj-4d0*ej*xwv

              avj=aj**2+vj**2

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=0.5d0*faczz*avi*avj

  820       CONTINUE

  830     CONTINUE

  840     CONTINUE


        ELSEIF(isub.EQ.72) THEN

C...Z0 + Z0 -> W+ + W-

          IF(sh.LE.4.01d0*sqmz) goto 870


          IF(mstp(46).LE.2) THEN

C...Exact scattering ME:s for on-mass-shell gauge bosons

            be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))

            cth2=cth**2

            th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)

            uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)

            IF(max(th,uh).GT.-1d0) goto 870

            shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*

     &      (1d0-2d0*sqmz/sh)

            ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang

            ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang

            atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*

     &      cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*

     &      ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*

     &      (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+

     &      2d0*(sqmw+sqmz)/sh*be2*cth))

            atwim=0d0

            auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*

     &      cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*

     &      ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*

     &      (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-

     &      2d0*(sqmw+sqmz)/sh*be2*cth))

            auwim=0d0

            a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)

            a4im=0d0

            facww=comfac*1d0/(4096d0*paru(1)**2*16d0*xw1**2)*

     &      (aem/xw)**4*(sh/sqmw)**2*(sqmz/sqmw)*sh2

            IF(mstp(46).LE.0) facww=facww*(ashre**2+ashim**2)

            IF(mstp(46).EQ.1) facww=facww*((ashre+atwre+auwre+a4re)**2+

     &      (ashim+atwim+auwim+a4im)**2)

            IF(mstp(46).EQ.2) facww=facww*((atwre+auwre+a4re)**2+

     &      (atwim+auwim+a4im)**2)


          ELSE

C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

            facww=comfac*(aem/(16d0*paru(1)*xw*xw1))**2*(64d0/9d0)*

     &      abs(a00u-a20u)**2

          ENDIF

          facww=facww*wids(24,1)


          DO 860 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 860

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            avi=ai**2+vi**2

            DO 850 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 850

              ej=kchg(iabs(j),1)/3d0

              aj=sign(1d0,ej)

              vj=aj-4d0*ej*xwv

              avj=aj**2+vj**2

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facww*avi*avj

  850       CONTINUE

  860     CONTINUE

  870     CONTINUE


        ELSEIF(isub.EQ.73) THEN

C...Z0 + W+/- -> Z0 + W+/-

          IF(sh.LE.2d0*sqmz+2d0*sqmw) goto 900


          IF(mstp(46).LE.2) THEN

C...Exact scattering ME:s for on-mass-shell gauge bosons

            be2=1d0-2d0*(sqmz+sqmw)/sh+((sqmz-sqmw)/sh)**2

            ep1=1d0-(sqmz-sqmw)/sh

            ep2=1d0+(sqmz-sqmw)/sh

            th=-0.5d0*sh*be2*(1d0-cth)

            uh=(sqmz-sqmw)**2/sh-0.5d0*sh*be2*(1d0+cth)

            IF(max(th,uh).GT.-1d0) goto 900

            thang=(be2-ep1*cth)*(be2-ep2*cth)

            athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang

            athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang

            aswre=-xw1/sqmz*sh/(sh-sqmw)*(-be2*(ep1+ep2)**4*cth+

     &      1d0/4d0*(be2+ep1*ep2)**2*((ep1-ep2)**2-4d0*be2*cth)+

     &      2d0*be2*(be2+ep1*ep2)*(ep1+ep2)**2*cth-

     &      1d0/16d0*sh/sqmw*(ep1**2-ep2**2)**2*(be2+ep1*ep2)**2)

            aswim=0d0

            auwre=xw1/sqmz*sh/(uh-sqmw)*(-be2*(ep2+ep1*cth)*

     &      (ep1+ep2*cth)*(be2+ep1*ep2)+be2*(ep2+ep1*cth)*

     &      (be2+ep1*ep2*cth)*(2d0*ep2-ep2*cth+ep1)-

     &      be2*(ep2+ep1*cth)**2*(be2-ep2**2*cth)-1d0/8d0*

     &      (be2+ep1*ep2*cth)**2*((ep1+ep2)**2+2d0*be2*(1d0-cth))+

     &      1d0/32d0*sh/sqmw*(be2+ep1*ep2*cth)**2*

     &      (ep1**2-ep2**2)**2-be2*(ep1+ep2*cth)*(ep2+ep1*cth)*

     &      (be2+ep1*ep2)+be2*(ep1+ep2*cth)*(be2+ep1*ep2*cth)*

     &      (2d0*ep1-ep1*cth+ep2)-be2*(ep1+ep2*cth)**2*

     &      (be2-ep1**2*cth)-1d0/8d0*(be2+ep1*ep2*cth)**2*

     &      ((ep1+ep2)**2+2d0*be2*(1d0-cth))+1d0/32d0*sh/sqmw*

     &      (be2+ep1*ep2*cth)**2*(ep1**2-ep2**2)**2)

            auwim=0d0

            a4re=xw1/sqmz*(ep1**2*ep2**2*(cth**2-1d0)-

     &      2d0*be2*(ep1**2+ep2**2+ep1*ep2)*cth-2d0*be2*ep1*ep2)

            a4im=0d0

            faczw=comfac*1d0/(4096d0*paru(1)**2*4d0*xw1)*(aem/xw)**4*

     &      (sh/sqmw)**2*sqrt(sqmz/sqmw)*sh2

            IF(mstp(46).LE.0) faczw=0d0

            IF(mstp(46).EQ.1) faczw=faczw*((athre+aswre+auwre+a4re)**2+

     &      (athim+aswim+auwim+a4im)**2)

            IF(mstp(46).EQ.2) faczw=faczw*((aswre+auwre+a4re)**2+

     &      (aswim+auwim+a4im)**2)


          ELSE

C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

            faczw=comfac*aem**2/(64d0*paru(1)**2*xw**2*xw1)*16d0*

     &      abs(a20u+3.*a11u*sngl(cth))**2

          ENDIF

          faczw=faczw*wids(23,2)


          DO 890 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 890

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            avi=ai**2+vi**2

            kchwi=isign(1,kchg(iabs(i),1)*isign(1,i))

            DO 880 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 880

              ej=kchg(iabs(j),1)/3d0

              aj=sign(1d0,ej)

              vj=ai-4d0*ej*xwv

              avj=aj**2+vj**2

              kchwj=isign(1,kchg(iabs(j),1)*isign(1,j))

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=faczw*avi*vint(180+j)*wids(24,(5-kchwj)/2)

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=2

              sigh(nchn)=faczw*vint(180+i)*wids(24,(5-kchwi)/2)*avj

  880       CONTINUE

  890     CONTINUE

  900     CONTINUE


        ELSEIF(isub.EQ.75) THEN

C...W+ + W- -> gamma + gamma


        ELSEIF(isub.EQ.76) THEN

C...W+ + W- -> Z0 + Z0

          IF(sh.LE.4.01d0*sqmz) goto 930


          IF(mstp(46).LE.2) THEN

C...Exact scattering ME:s for on-mass-shell gauge bosons

            be2=sqrt((1d0-4d0*sqmw/sh)*(1d0-4d0*sqmz/sh))

            cth2=cth**2

            th=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh-be2*cth)

            uh=-0.5d0*sh*(1d0-2d0*(sqmw+sqmz)/sh+be2*cth)

            IF(max(th,uh).GT.-1d0) goto 930

            shang=4d0*sqrt(sqmw/(sqmz*xw1))*(1d0-2d0*sqmw/sh)*

     &      (1d0-2d0*sqmz/sh)

            ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang

            ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang

            atwre=xw1/sqmz*sh/(th-sqmw)*((cth-be2)**2*(3d0/2d0+be2/2d0*

     &      cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*

     &      ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*

     &      (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2+

     &      2d0*(sqmw+sqmz)/sh*be2*cth))

            atwim=0d0

            auwre=xw1/sqmz*sh/(uh-sqmw)*((cth+be2)**2*(3d0/2d0-be2/2d0*

     &      cth-(sqmw+sqmz)/sh+(sqmw-sqmz)**2/(sh*sqmw))+4d0*

     &      ((sqmw+sqmz)/sh*(1d0-3d0*cth2)+8d0*sqmw*sqmz/sh2*

     &      (2d0*cth2-1d0)+4d0*(sqmw**2+sqmz**2)/sh2*cth2-

     &      2d0*(sqmw+sqmz)/sh*be2*cth))

            auwim=0d0

            a4re=2d0*xw1/sqmz*(3d0-cth2-4d0*(sqmw+sqmz)/sh)

            a4im=0d0

            faczz=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*

     &      (sh/sqmw)**2*sh2

            IF(mstp(46).LE.0) faczz=faczz*(ashre**2+ashim**2)

            IF(mstp(46).EQ.1) faczz=faczz*((ashre+atwre+auwre+a4re)**2+

     &      (ashim+atwim+auwim+a4im)**2)

            IF(mstp(46).EQ.2) faczz=faczz*((atwre+auwre+a4re)**2+

     &      (atwim+auwim+a4im)**2)


          ELSE

C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

            faczz=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*

     &      abs(a00u-a20u)**2

          ENDIF

          faczz=faczz*wids(23,1)


          DO 920 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 920

            ei=sign(1d0,dble(i))*kchg(iabs(i),1)

            DO 910 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 910

              ej=sign(1d0,dble(j))*kchg(iabs(j),1)

              IF(ei*ej.GT.0d0) goto 910

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=0.5d0*faczz*vint(180+i)*vint(180+j)

  910       CONTINUE

  920     CONTINUE

  930     CONTINUE


        ELSEIF(isub.EQ.77) THEN

C...W+/- + W+/- -> W+/- + W+/-

          IF(sh.LE.4.01d0*sqmw) goto 960


          IF(mstp(46).LE.2) THEN

C...Exact scattering ME:s for on-mass-shell gauge bosons

            be2=1d0-4d0*sqmw/sh

            be4=be2**2

            cth2=cth**2

            cth3=cth**3

            th=-0.5d0*sh*be2*(1d0-cth)

            uh=-0.5d0*sh*be2*(1d0+cth)

            IF(max(th,uh).GT.-1d0) goto 960

            shang=(1d0+be2)**2

            ashre=(sh-sqmh)/((sh-sqmh)**2+gmmh**2)*shang

            ashim=-gmmh/((sh-sqmh)**2+gmmh**2)*shang

            thang=(be2-cth)**2

            athre=(th-sqmh)/((th-sqmh)**2+gmmh**2)*thang

            athim=-gmmh/((th-sqmh)**2+gmmh**2)*thang

            uhang=(be2+cth)**2

            auhre=(uh-sqmh)/((uh-sqmh)**2+gmmh**2)*uhang

            auhim=-gmmh/((uh-sqmh)**2+gmmh**2)*uhang

            sgzang=1d0/sqmw*be2*(3d0-be2)**2*cth

            asgre=xw*sgzang

            asgim=0d0

            aszre=xw1*sh/(sh-sqmz)*sgzang

            aszim=0d0

            tgzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)+be2*(4d0-10d0*be2+

     &      be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2+be2*cth3)

            atgre=0.5d0*xw*sh/th*tgzang

            atgim=0d0

            atzre=0.5d0*xw1*sh/(th-sqmz)*tgzang

            atzim=0d0

            ugzang=1d0/sqmw*(be2*(4d0-2d0*be2+be4)-be2*(4d0-10d0*be2+

     &      be4)*cth+(2d0-11d0*be2+10d0*be4)*cth2-be2*cth3)

            augre=0.5d0*xw*sh/uh*ugzang

            augim=0d0

            auzre=0.5d0*xw1*sh/(uh-sqmz)*ugzang

            auzim=0d0

            a4are=1d0/sqmw*(1d0+2d0*be2-6d0*be2*cth-cth2)

            a4aim=0d0

            a4sre=2d0/sqmw*(1d0+2d0*be2-cth2)

            a4sim=0d0

            fww=comfac*1d0/(4096d0*paru(1)**2)*(aem/xw)**4*

     &      (sh/sqmw)**2*sh2

            IF(mstp(46).LE.0) THEN

              awware=ashre

              awwaim=ashim

              awwsre=0d0

              awwsim=0d0

            ELSEIF(mstp(46).EQ.1) THEN

              awware=ashre+athre+asgre+aszre+atgre+atzre+a4are

              awwaim=ashim+athim+asgim+aszim+atgim+atzim+a4aim

              awwsre=-athre-auhre+atgre+atzre+augre+auzre+a4sre

              awwsim=-athim-auhim+atgim+atzim+augim+auzim+a4sim

            ELSE

              awware=asgre+aszre+atgre+atzre+a4are

              awwaim=asgim+aszim+atgim+atzim+a4aim

              awwsre=atgre+atzre+augre+auzre+a4sre

              awwsim=atgim+atzim+augim+auzim+a4sim

            ENDIF

            awwa2=awware**2+awwaim**2

            awws2=awwsre**2+awwsim**2


          ELSE

C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron

            fwwa=comfac*(aem/(4d0*paru(1)*xw))**2*(64d0/9d0)*

     &      abs(a00u+0.5*a20u+4.5*a11u*sngl(cth))**2

            fwws=comfac*(aem/(4d0*paru(1)*xw))**2*64d0*abs(a20u)**2

          ENDIF


          DO 950 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 950

            ei=sign(1d0,dble(i))*kchg(iabs(i),1)

            DO 940 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 940

              ej=sign(1d0,dble(j))*kchg(iabs(j),1)

              IF(ei*ej.LT.0d0) THEN

C...W+W-

                IF(mstp(45).EQ.1) goto 940

                IF(mstp(46).LE.2) facww=fww*awwa2*wids(24,1)

                IF(mstp(46).GE.3) facww=fwwa*wids(24,1)

              ELSE

C...W+W+/W-W-

                IF(mstp(45).EQ.2) goto 940

                IF(mstp(46).LE.2) facww=fww*awws2

                IF(mstp(46).GE.3) facww=fwws

                IF(ei.GT.0d0) facww=facww*wids(24,4)

                IF(ei.LT.0d0) facww=facww*wids(24,5)

              ENDIF

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facww*vint(180+i)*vint(180+j)

              IF(ei*ej.GT.0d0) sigh(nchn)=0.5d0*sigh(nchn)

  940       CONTINUE

  950     CONTINUE

  960     CONTINUE


        ELSEIF(isub.EQ.78) THEN

C...W+/- + h0 -> W+/- + h0


        ELSEIF(isub.EQ.79) THEN

C...h0 + h0 -> h0 + h0


        ELSEIF(isub.EQ.80) THEN

C...q + gamma -> q' + pi+/-

          fqpi=comfac*(2d0*aem/9d0)*(-sh/th)*(1d0/sh2+1d0/th2)

          assh=pyalps(max(0.5d0,0.5d0*sh))

          q2fpsh=0.55d0/log(max(2d0,2d0*sh))

          delsh=uh*sqrt(assh*q2fpsh)

          asuh=pyalps(max(0.5d0,-0.5d0*uh))

          q2fpuh=0.55d0/log(max(2d0,-2d0*uh))

          deluh=sh*sqrt(asuh*q2fpuh)

          DO 980 i=max(-2,mmina),min(2,mmaxa)

            IF(i.EQ.0) goto 980

            ei=kchg(iabs(i),1)/3d0

            ej=sign(1d0-abs(ei),ei)

            DO 970 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,22).EQ.0) goto 970

              IF(isde.EQ.2.AND.kfac(1,22)*kfac(2,i).EQ.0) goto 970

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=22

              isig(nchn,3)=1

              sigh(nchn)=fqpi*(ei*delsh+ej*deluh)**2

  970       CONTINUE

  980     CONTINUE


        ENDIF


C...C: 2 -> 2, tree diagrams with masses


      ELSEIF(isub.LE.90) THEN

        IF(isub.EQ.81) THEN

C...q + qbar -> Q + Qbar

          facqqb=comfac*as**2*4d0/9d0*(((th-sqm3)**2+

     &    (uh-sqm3)**2)/sh2+2d0*sqm3/sh)

          IF(mstp(35).GE.1) facqqb=facqqb*pyhfth(sh,sqm3,0d0)

          wid2=1d0

          IF(mint(55).EQ.6) wid2=wids(6,1)

          IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)

          facqqb=facqqb*wid2

          DO 990 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 990

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqqb

  990     CONTINUE


        ELSEIF(isub.EQ.82) THEN

C...g + g -> Q + Qbar

          IF(mstp(34).EQ.0) THEN

            facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqm3)/(th-sqm3)-

     &      2d0*(uh-sqm3)**2/sh2+4d0*(sqm3/sh)*(th*uh-sqm3**2)/

     &      (th-sqm3)**2)

            facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqm3)/(uh-sqm3)-

     &      2d0*(th-sqm3)**2/sh2+4d0*(sqm3/sh)*(th*uh-sqm3**2)/

     &      (uh-sqm3)**2)

          ELSE

            facqq1=comfac*faca*as**2*(1d0/6d0)*((uh-sqm3)/(th-sqm3)-

     &      2.25d0*(uh-sqm3)**2/sh2+4.5d0*(sqm3/sh)*(th*uh-sqm3**2)/

     &      (th-sqm3)**2+0.5d0*sqm3*th/(th-sqm3)**2-sqm3**2/

     &      (sh*(th-sqm3)))

            facqq2=comfac*faca*as**2*(1d0/6d0)*((th-sqm3)/(uh-sqm3)-

     &      2.25d0*(th-sqm3)**2/sh2+4.5d0*(sqm3/sh)*(th*uh-sqm3**2)/

     &      (uh-sqm3)**2+0.5d0*sqm3*uh/(uh-sqm3)**2-sqm3**2/

     &      (sh*(uh-sqm3)))

          ENDIF

          IF(mstp(35).GE.1) THEN

            fatre=pyhfth(sh,sqm3,2d0/7d0)

            facqq1=facqq1*fatre

            facqq2=facqq2*fatre

          ENDIF

          wid2=1d0

          IF(mint(55).EQ.6) wid2=wids(6,1)

          IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)

          facqq1=facqq1*wid2

          facqq2=facqq2*wid2

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1000

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqq1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=facqq2

 1000     CONTINUE


        ELSEIF(isub.EQ.83) THEN

C...f + q -> f' + Q

          facqqs=comfac*(0.5d0*aem/xw)**2*sh*(sh-sqm3)/(sqmw-th)**2

          facqqu=comfac*(0.5d0*aem/xw)**2*uh*(uh-sqm3)/(sqmw-th)**2

          DO 1020 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1020

            DO 1010 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1010

              IF(i*j.GT.0.AND.mod(iabs(i+j),2).EQ.0) goto 1010

              IF(i*j.LT.0.AND.mod(iabs(i+j),2).EQ.1) goto 1010

              IF(iabs(i).LT.mint(55).AND.mod(iabs(i+mint(55)),2).EQ.1)

     &        THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,

     &          (iabs(i)+1)/2)*vint(180+j)

                IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(i)/2,

     &          (mint(55)+1)/2)*vint(180+j)

                wid2=1d0

                IF(i.GT.0) THEN

                  IF(mint(55).EQ.6) wid2=wids(6,2)

                  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=

     &            wids(mint(55),2)

                ELSE

                  IF(mint(55).EQ.6) wid2=wids(6,3)

                  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=

     &            wids(mint(55),3)

                ENDIF

                IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2

                IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2

              ENDIF

              IF(iabs(j).LT.mint(55).AND.mod(iabs(j+mint(55)),2).EQ.1)

     &        THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                IF(mod(mint(55),2).EQ.0) facckm=vckm(mint(55)/2,

     &          (iabs(j)+1)/2)*vint(180+i)

                IF(mod(mint(55),2).EQ.1) facckm=vckm(iabs(j)/2,

     &          (mint(55)+1)/2)*vint(180+i)

                IF(j.GT.0) THEN

                  IF(mint(55).EQ.6) wid2=wids(6,2)

                  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=

     &            wids(mint(55),2)

                ELSE

                  IF(mint(55).EQ.6) wid2=wids(6,3)

                  IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=

     &            wids(mint(55),3)

                ENDIF

                IF(i*j.GT.0) sigh(nchn)=facqqs*facckm*wid2

                IF(i*j.LT.0) sigh(nchn)=facqqu*facckm*wid2

              ENDIF

 1010       CONTINUE

 1020     CONTINUE


        ELSEIF(isub.EQ.84) THEN

C...g + gamma -> Q + Qbar

          fmtu=sqm3/(sqm3-th)+sqm3/(sqm3-uh)

          facqq=comfac*as*aem*(kchg(iabs(mint(55)),1)/3d0)**2*

     &    ((sqm3-th)/(sqm3-uh)+(sqm3-uh)/(sqm3-th)+4d0*fmtu*(1d0-fmtu))

          IF(mstp(35).GE.1) facqq=facqq*pyhfth(sh,sqm3,0d0)

          wid2=1d0

          IF(mint(55).EQ.6) wid2=wids(6,1)

          IF(mint(55).EQ.7.OR.mint(55).EQ.8) wid2=wids(mint(55),1)

          facqq=facqq*wid2

          IF(kfac(1,21)*kfac(2,22).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=22

            isig(nchn,3)=1

            sigh(nchn)=facqq

          ENDIF

          IF(kfac(1,22)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=22

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqq

          ENDIF


        ELSEIF(isub.EQ.85) THEN

C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)

          fmtu=sqm3/(sqm3-th)+sqm3/(sqm3-uh)

          facff=comfac*aem**2*(kchg(iabs(mint(56)),1)/3d0)**4*2d0*

     &    ((sqm3-th)/(sqm3-uh)+(sqm3-uh)/(sqm3-th)+4d0*fmtu*(1d0-fmtu))

          IF(iabs(mint(56)).LT.10) facff=3d0*facff

          IF(iabs(mint(56)).LT.10.AND.mstp(35).GE.1)

     &    facff=facff*pyhfth(sh,sqm3,1d0)

          wid2=1d0

          IF(mint(56).EQ.6) wid2=wids(6,1)

          IF(mint(56).EQ.7.OR.mint(56).EQ.8) wid2=wids(mint(56),1)

          IF(mint(56).EQ.17) wid2=wids(17,1)

          facff=facff*wid2

          IF(kfac(1,22)*kfac(2,22).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=22

            isig(nchn,2)=22

            isig(nchn,3)=1

            sigh(nchn)=facff

          ENDIF


        ELSEIF(isub.EQ.86) THEN

C...g + g -> J/Psi + g

          facqqg=comfac*as**3*(5d0/9d0)*parp(38)*sqrt(sqm3)*

     &    (((sh*(sh-sqm3))**2+(th*(th-sqm3))**2+(uh*(uh-sqm3))**2)/

     &    ((th-sqm3)*(uh-sqm3))**2)/(sh-sqm3)**2

          IF(kfac(1,21)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqqg

          ENDIF


        ELSEIF(isub.EQ.87) THEN

C...g + g -> chi_0c + g

          pgtw=(sh*th+th*uh+uh*sh)/sh2

          qgtw=(sh*th*uh)/sh**3

          rgtw=sqm3/sh

          facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*

     &    (9d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-

     &    6d0*rgtw*pgtw**3*qgtw*(2d0*rgtw**4-5d0*rgtw**2*pgtw+pgtw**2)-

     &    pgtw**2*qgtw**2*(rgtw**4+2d0*rgtw**2*pgtw-pgtw**2)+

     &    2d0*rgtw*pgtw*qgtw**3*(rgtw**2-pgtw)+6d0*rgtw**2*qgtw**4)/

     &    (qgtw*(qgtw-rgtw*pgtw)**4)

          IF(kfac(1,21)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqqg

          ENDIF


        ELSEIF(isub.EQ.88) THEN

C...g + g -> chi_1c + g

          pgtw=(sh*th+th*uh+uh*sh)/sh2

          qgtw=(sh*th*uh)/sh**3

          rgtw=sqm3/sh

          facqqg=comfac*as**3*12d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*

     &    pgtw**2*(rgtw*pgtw**2*(rgtw**2-4d0*pgtw)+2d0*qgtw*(-rgtw**4+

     &    5d0*rgtw**2*pgtw+pgtw**2)-15d0*rgtw*qgtw**2)/

     &    (qgtw-rgtw*pgtw)**4

          IF(kfac(1,21)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqqg

          ENDIF


        ELSEIF(isub.EQ.89) THEN

C...g + g -> chi_2c + g

          pgtw=(sh*th+th*uh+uh*sh)/sh2

          qgtw=(sh*th*uh)/sh**3

          rgtw=sqm3/sh

          facqqg=comfac*as**3*4d0*(parp(39)/sqrt(sqm3))*(1d0/sh)*

     &    (12d0*rgtw**2*pgtw**4*(rgtw**4-2d0*rgtw**2*pgtw+pgtw**2)-

     &    3d0*rgtw*pgtw**3*qgtw*(8d0*rgtw**4-rgtw**2*pgtw+4d0*pgtw**2)+

     &    2d0*pgtw**2*qgtw**2*(-7d0*rgtw**4+43d0*rgtw**2*pgtw+pgtw**2)+

     &    rgtw*pgtw*qgtw**3*(16d0*rgtw**2-61d0*pgtw)+12d0*rgtw**2*

     &    qgtw**4)/(qgtw*(qgtw-rgtw*pgtw)**4)

          IF(kfac(1,21)*kfac(2,21).NE.0) THEN

            nchn=nchn+1

            isig(nchn,1)=21

            isig(nchn,2)=21

            isig(nchn,3)=1

            sigh(nchn)=facqqg

          ENDIF

        ENDIF


C...D: Mimimum bias processes


      ELSEIF(isub.LE.100) THEN

        IF(isub.EQ.91) THEN

C...Elastic scattering

          sigs=sigt(0,0,1)


        ELSEIF(isub.EQ.92) THEN

C...Single diffractive scattering (first side, i.e. XB)

          sigs=sigt(0,0,2)


        ELSEIF(isub.EQ.93) THEN

C...Single diffractive scattering (second side, i.e. AX)

          sigs=sigt(0,0,3)


        ELSEIF(isub.EQ.94) THEN

C...Double diffractive scattering

          sigs=sigt(0,0,4)


        ELSEIF(isub.EQ.95) THEN

C...Low-pT scattering

          sigs=sigt(0,0,5)


        ELSEIF(isub.EQ.96) THEN

C...Multiple interactions: sum of QCD processes

          CALL pywidt(21,sh,wdtp,wdte)


C...q + q' -> q + q'

          facqq1=comfac*as**2*4d0/9d0*(sh2+uh2)/th2

          facqqb=comfac*as**2*4d0/9d0*((sh2+uh2)/th2*faca-

     &    mstp(34)*2d0/3d0*uh2/(sh*th))

          facqq2=comfac*as**2*4d0/9d0*((sh2+th2)/uh2-

     &    mstp(34)*2d0/3d0*sh2/(th*uh))

          DO 1040 i=-3,3

            IF(i.EQ.0) goto 1040

            DO 1030 j=-3,3

              IF(j.EQ.0) goto 1030

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=111

              sigh(nchn)=facqq1

              IF(i.EQ.-j) sigh(nchn)=facqqb

              IF(i.EQ.j) THEN

                sigh(nchn)=0.5d0*sigh(nchn)

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=112

                sigh(nchn)=0.5d0*facqq2

              ENDIF

 1030       CONTINUE

 1040     CONTINUE


C...q + qbar -> q' + qbar' or g + g

          facqqb=comfac*as**2*4d0/9d0*(th2+uh2)/sh2*

     &    (wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))

          facgg1=comfac*as**2*32d0/27d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*

     &    uh2/sh2)

          facgg2=comfac*as**2*32d0/27d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*

     &    th2/sh2)

          DO 1050 i=-3,3

            IF(i.EQ.0) goto 1050

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=121

            sigh(nchn)=facqqb

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=131

            sigh(nchn)=0.5d0*facgg1

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=132

            sigh(nchn)=0.5d0*facgg2

 1050     CONTINUE


C...q + g -> q + g

          facqg1=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*uh2/th2-

     &    uh/sh)*faca

          facqg2=comfac*as**2*4d0/9d0*((2d0+mstp(34)*1d0/4d0)*sh2/th2-

     &    sh/uh)

          DO 1070 i=-3,3

            IF(i.EQ.0) goto 1070

            DO 1060 isde=1,2

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=281

              sigh(nchn)=facqg1

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=282

              sigh(nchn)=facqg2

 1060       CONTINUE

 1070     CONTINUE


C...g + g -> q + qbar or g + g

          facqq1=comfac*as**2*1d0/6d0*(uh/th-(2d0+mstp(34)*1d0/4d0)*

     &    uh2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca

          facqq2=comfac*as**2*1d0/6d0*(th/uh-(2d0+mstp(34)*1d0/4d0)*

     &    th2/sh2)*(wdte(0,1)+wdte(0,2)+wdte(0,3)+wdte(0,4))*faca

          facgg1=comfac*as**2*9d0/4d0*(sh2/th2+2d0*sh/th+3d0+

     &    2d0*th/sh+th2/sh2)*faca

          facgg2=comfac*as**2*9d0/4d0*(uh2/sh2+2d0*uh/sh+3d0+

     &    2d0*sh/uh+sh2/uh2)*faca

          facgg3=comfac*as**2*9d0/4d0*(th2/uh2+2d0*th/uh+3+

     &    2d0*uh/th+uh2/th2)

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=531

          sigh(nchn)=facqq1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=532

          sigh(nchn)=facqq2

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=681

          sigh(nchn)=0.5d0*facgg1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=682

          sigh(nchn)=0.5d0*facgg2

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=683

          sigh(nchn)=0.5d0*facgg3

        ENDIF


C...E: 2 -> 1, loop diagrams


      ELSEIF(isub.LE.110) THEN

        IF(isub.EQ.101) THEN

C...g + g -> gamma*/Z0


        ELSEIF(isub.EQ.102) THEN

C...g + g -> h0 (or H0, or A0)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=4d0*comfac/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          hi=shr*wdtp(13)/32d0

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1080

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=hi*facbw*hf

 1080     CONTINUE


        ELSEIF(isub.EQ.103) THEN

C...gamma + gamma -> h0 (or H0, or A0)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=4d0*comfac/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          hi=shr*wdtp(14)*2d0

          IF(kfac(1,22)*kfac(2,22).EQ.0) goto 1090

          nchn=nchn+1

          isig(nchn,1)=22

          isig(nchn,2)=22

          isig(nchn,3)=1

          sigh(nchn)=hi*facbw*hf

 1090     CONTINUE


C...F: 2 -> 2, box diagrams


        ELSEIF(isub.EQ.110) THEN

C...f + fbar -> gamma + h0

          thuh=max(th*uh,sh*ckin(3)**2)

          fachg=comfac*(3d0*aem**4)/(2d0*paru(1)**2*xw*sqmw)*sh*thuh

          fachg=fachg*wids(kfhigg,2)

C...Calculate loop contributions for intermediate gamma* and Z0

          cigtot=cmplx(0.,0.)

          ciztot=cmplx(0.,0.)

          jmax=3*mstp(1)+1

          DO 1100 j=1,jmax

            IF(j.LE.2*mstp(1)) THEN

              fnc=1d0

              ej=kchg(j,1)/3d0

              aj=sign(1d0,ej+0.1d0)

              vj=aj-4d0*ej*xwv

              balp=sqm4/(2d0*pmas(j,1))**2

              bbet=sh/(2d0*pmas(j,1))**2

            ELSEIF(j.LE.3*mstp(1)) THEN

              fnc=3d0

              jl=2*(j-2*mstp(1))-1

              ej=kchg(10+jl,1)/3d0

              aj=sign(1d0,ej+0.1d0)

              vj=aj-4d0*ej*xwv

              balp=sqm4/(2d0*pmas(10+jl,1))**2

              bbet=sh/(2d0*pmas(10+jl,1))**2

            ELSE

              balp=sqm4/(2d0*pmas(24,1))**2

              bbet=sh/(2d0*pmas(24,1))**2

            ENDIF

            babi=1d0/(balp-bbet)

            IF(balp.LT.1d0) THEN

              f0alp=cmplx(sngl(asin(sqrt(balp))),0.)

              f1alp=f0alp**2

            ELSE

              f0alp=cmplx(sngl(log(sqrt(balp)+sqrt(balp-1d0))),

     &        -sngl(0.5d0*paru(1)))

              f1alp=-f0alp**2

            ENDIF

            f2alp=sngl(sqrt(abs(balp-1d0)/balp))*f0alp

            IF(bbet.LT.1d0) THEN

              f0bet=cmplx(sngl(asin(sqrt(bbet))),0.)

              f1bet=f0bet**2

            ELSE

              f0bet=cmplx(sngl(log(sqrt(bbet)+sqrt(bbet-1d0))),

     &        -sngl(0.5d0*paru(1)))

              f1bet=-f0bet**2

            ENDIF

            f2bet=sngl(sqrt(abs(bbet-1d0)/bbet))*f0bet

            IF(j.LE.3*mstp(1)) THEN

              fif=sngl(0.5d0*babi)+sngl(babi**2)*(sngl(0.5d0*(1d0-balp+

     &        bbet))*(f1bet-f1alp)+sngl(bbet)*(f2bet-f2alp))

              cigtot=cigtot+sngl(fnc*ej**2)*fif

              ciztot=ciztot+sngl(fnc*ej*vj)*fif

            ELSE

              txw=xw/xw1

              cigtot=cigtot-0.5*(sngl(babi*(1.5d0+balp))+sngl(babi**2)*

     &        (sngl(1.5d0-3d0*balp+4d0*bbet)*(f1bet-f1alp)+

     &        sngl(bbet*(2d0*balp+3d0))*(f2bet-f2alp)))

              ciztot=ciztot-sngl(0.5d0*babi*xw1)*(sngl(5d0-txw+2d0*balp*

     &        (1d0-txw))*(1.+sngl(2d0*babi*bbet)*(f2bet-f2alp))+

     &        sngl(babi*(4d0*bbet*(3d0-txw)-(2d0*balp-1d0)*(5d0-txw)))*

     &        (f1bet-f1alp))

            ENDIF

 1100     CONTINUE

          cigtot=cigtot/sngl(sh)

          ciztot=ciztot*sngl(xwc)/cmplx(sngl(sh-sqmz),sngl(gmmz))

C...Loop over initial flavours

          DO 1110 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1110

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=fachg*fcoi*(abs(sngl(ei)*cigtot+sngl(vi)*

     &      ciztot)**2+ai**2*abs(ciztot)**2)

 1110     CONTINUE


        ENDIF


      ELSEIF(isub.LE.120) THEN

        IF(isub.EQ.111) THEN

C...f + fbar -> g + h0 (q + qbar -> g + h0 only)

          a5stur=0d0

          a5stui=0d0

          DO 1120 i=1,2*mstp(1)

            sqmq=pmas(i,1)**2

            epss=4d0*sqmq/sh

            epsh=4d0*sqmq/sqmh

            CALL pywaux(1,epss,w1sr,w1si)

            CALL pywaux(1,epsh,w1hr,w1hi)

            CALL pywaux(2,epss,w2sr,w2si)

            CALL pywaux(2,epsh,w2hr,w2hi)

            a5stur=a5stur+epsh*(1d0+sh/(th+uh)*(w1sr-w1hr)+

     &      (0.25d0-sqmq/(th+uh))*(w2sr-w2hr))

            a5stui=a5stui+epsh*(sh/(th+uh)*(w1si-w1hi)+

     &      (0.25d0-sqmq/(th+uh))*(w2si-w2hi))

 1120     CONTINUE

          facgh=comfac*faca/(144d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*

     &    sqmh/sh*(uh**2+th**2)/(uh+th)**2*(a5stur**2+a5stui**2)

          facgh=facgh*wids(25,2)

          DO 1130 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 1130

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facgh

 1130     CONTINUE


        ELSEIF(isub.EQ.112) THEN

C...f + g -> f + h0 (q + g -> q + h0 only)

          a5tsur=0d0

          a5tsui=0d0

          DO 1140 i=1,2*mstp(1)

            sqmq=pmas(i,1)**2

            epst=4d0*sqmq/th

            epsh=4d0*sqmq/sqmh

            CALL pywaux(1,epst,w1tr,w1ti)

            CALL pywaux(1,epsh,w1hr,w1hi)

            CALL pywaux(2,epst,w2tr,w2ti)

            CALL pywaux(2,epsh,w2hr,w2hi)

            a5tsur=a5tsur+epsh*(1d0+th/(sh+uh)*(w1tr-w1hr)+

     &      (0.25d0-sqmq/(sh+uh))*(w2tr-w2hr))

            a5tsui=a5tsui+epsh*(th/(sh+uh)*(w1ti-w1hi)+

     &      (0.25d0-sqmq/(sh+uh))*(w2ti-w2hi))

 1140     CONTINUE

          facqh=comfac*faca/(384d0*paru(1)**2)*aem/xw*as**3*sqmh/sqmw*

     &    sqmh/(-th)*(uh**2+sh**2)/(uh+sh)**2*(a5tsur**2+a5tsui**2)

          facqh=facqh*wids(25,2)

          DO 1160 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1160

            DO 1150 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1150

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1150

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=facqh

 1150       CONTINUE

 1160     CONTINUE


        ELSEIF(isub.EQ.113) THEN

C...g + g -> g + h0

          a2stur=0d0

          a2stui=0d0

          a2ustr=0d0

          a2usti=0d0

          a2tusr=0d0

          a2tusi=0d0

          a4stur=0d0

          a4stui=0d0

          DO 1170 i=1,2*mstp(1)

            sqmq=pmas(i,1)**2

            epss=4d0*sqmq/sh

            epst=4d0*sqmq/th

            epsu=4d0*sqmq/uh

            epsh=4d0*sqmq/sqmh

            IF(epsh.LT.1.d-6) goto 1170

            CALL pywaux(1,epss,w1sr,w1si)

            CALL pywaux(1,epst,w1tr,w1ti)

            CALL pywaux(1,epsu,w1ur,w1ui)

            CALL pywaux(1,epsh,w1hr,w1hi)

            CALL pywaux(2,epss,w2sr,w2si)

            CALL pywaux(2,epst,w2tr,w2ti)

            CALL pywaux(2,epsu,w2ur,w2ui)

            CALL pywaux(2,epsh,w2hr,w2hi)

            CALL pyi3au(epss,th/uh,y3stur,y3stui)

            CALL pyi3au(epss,uh/th,y3sutr,y3suti)

            CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)

            CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)

            CALL pyi3au(epsu,sh/th,y3ustr,y3usti)

            CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)

            CALL pyi3au(epsh,sqmh/sh*th/uh,yhstur,yhstui)

            CALL pyi3au(epsh,sqmh/sh*uh/th,yhsutr,yhsuti)

            CALL pyi3au(epsh,sqmh/th*sh/uh,yhtsur,yhtsui)

            CALL pyi3au(epsh,sqmh/th*uh/sh,yhtusr,yhtusi)

            CALL pyi3au(epsh,sqmh/uh*sh/th,yhustr,yhusti)

            CALL pyi3au(epsh,sqmh/uh*th/sh,yhutsr,yhutsi)

            w3stur=yhstur-y3stur-y3utsr

            w3stui=yhstui-y3stui-y3utsi

            w3sutr=yhsutr-y3sutr-y3tusr

            w3suti=yhsuti-y3suti-y3tusi

            w3tsur=yhtsur-y3tsur-y3ustr

            w3tsui=yhtsui-y3tsui-y3usti

            w3tusr=yhtusr-y3tusr-y3sutr

            w3tusi=yhtusi-y3tusi-y3suti

            w3ustr=yhustr-y3ustr-y3tsur

            w3usti=yhusti-y3usti-y3tsui

            w3utsr=yhutsr-y3utsr-y3stur

            w3utsi=yhutsi-y3utsi-y3stui

            b2stur=sqmq/sqmh**2*(sh*(uh-sh)/(sh+uh)+2d0*th*uh*

     &      (uh+2d0*sh)/(sh+uh)**2*(w1tr-w1hr)+(sqmq-sh/4d0)*

     &      (0.5d0*w2sr+0.5d0*w2hr-w2tr+w3stur)+sh2*(2d0*sqmq/

     &      (sh+uh)**2-0.5d0/(sh+uh))*(w2tr-w2hr)+0.5d0*th*uh/sh*

     &      (w2hr-2d0*w2tr)+0.125d0*(sh-12d0*sqmq-4d0*th*uh/sh)*w3tsur)

            b2stui=sqmq/sqmh**2*(2d0*th*uh*(uh+2d0*sh)/(sh+uh)**2*

     &      (w1ti-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ti+

     &      w3stui)+sh2*(2d0*sqmq/(sh+uh)**2-0.5d0/(sh+uh))*

     &      (w2ti-w2hi)+0.5d0*th*uh/sh*(w2hi-2d0*w2ti)+0.125d0*

     &      (sh-12d0*sqmq-4d0*th*uh/sh)*w3tsui)

            b2sutr=sqmq/sqmh**2*(sh*(th-sh)/(sh+th)+2d0*uh*th*

     &      (th+2d0*sh)/(sh+th)**2*(w1ur-w1hr)+(sqmq-sh/4d0)*

     &      (0.5d0*w2sr+0.5d0*w2hr-w2ur+w3sutr)+sh2*(2d0*sqmq/

     &      (sh+th)**2-0.5d0/(sh+th))*(w2ur-w2hr)+0.5d0*uh*th/sh*

     &      (w2hr-2d0*w2ur)+0.125d0*(sh-12d0*sqmq-4d0*uh*th/sh)*w3ustr)

            b2suti=sqmq/sqmh**2*(2d0*uh*th*(th+2d0*sh)/(sh+th)**2*

     &      (w1ui-w1hi)+(sqmq-sh/4d0)*(0.5d0*w2si+0.5d0*w2hi-w2ui+

     &      w3suti)+sh2*(2d0*sqmq/(sh+th)**2-0.5d0/(sh+th))*

     &      (w2ui-w2hi)+0.5d0*uh*th/sh*(w2hi-2d0*w2ui)+0.125d0*

     &      (sh-12d0*sqmq-4d0*uh*th/sh)*w3usti)

            b2tsur=sqmq/sqmh**2*(th*(uh-th)/(th+uh)+2d0*sh*uh*

     &      (uh+2d0*th)/(th+uh)**2*(w1sr-w1hr)+(sqmq-th/4d0)*

     &      (0.5d0*w2tr+0.5d0*w2hr-w2sr+w3tsur)+th2*(2d0*sqmq/

     &      (th+uh)**2-0.5d0/(th+uh))*(w2sr-w2hr)+0.5d0*sh*uh/th*

     &      (w2hr-2d0*w2sr)+0.125d0*(th-12d0*sqmq-4d0*sh*uh/th)*w3stur)

            b2tsui=sqmq/sqmh**2*(2d0*sh*uh*(uh+2d0*th)/(th+uh)**2*

     &      (w1si-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2si+

     &      w3tsui)+th2*(2d0*sqmq/(th+uh)**2-0.5d0/(th+uh))*

     &      (w2si-w2hi)+0.5d0*sh*uh/th*(w2hi-2d0*w2si)+0.125d0*

     &      (th-12d0*sqmq-4d0*sh*uh/th)*w3stui)

            b2tusr=sqmq/sqmh**2*(th*(sh-th)/(th+sh)+2d0*uh*sh*

     &      (sh+2d0*th)/(th+sh)**2*(w1ur-w1hr)+(sqmq-th/4d0)*

     &      (0.5d0*w2tr+0.5d0*w2hr-w2ur+w3tusr)+th2*(2d0*sqmq/

     &      (th+sh)**2-0.5d0/(th+sh))*(w2ur-w2hr)+0.5d0*uh*sh/th*

     &      (w2hr-2d0*w2ur)+0.125d0*(th-12d0*sqmq-4d0*uh*sh/th)*w3utsr)

            b2tusi=sqmq/sqmh**2*(2d0*uh*sh*(sh+2d0*th)/(th+sh)**2*

     &      (w1ui-w1hi)+(sqmq-th/4d0)*(0.5d0*w2ti+0.5d0*w2hi-w2ui+

     &      w3tusi)+th2*(2d0*sqmq/(th+sh)**2-0.5d0/(th+sh))*

     &      (w2ui-w2hi)+0.5d0*uh*sh/th*(w2hi-2d0*w2ui)+0.125d0*

     &      (th-12d0*sqmq-4d0*uh*sh/th)*w3utsi)

            b2ustr=sqmq/sqmh**2*(uh*(th-uh)/(uh+th)+2d0*sh*th*

     &      (th+2d0*uh)/(uh+th)**2*(w1sr-w1hr)+(sqmq-uh/4d0)*

     &      (0.5d0*w2ur+0.5d0*w2hr-w2sr+w3ustr)+uh2*(2d0*sqmq/

     &      (uh+th)**2-0.5d0/(uh+th))*(w2sr-w2hr)+0.5d0*sh*th/uh*

     &      (w2hr-2d0*w2sr)+0.125d0*(uh-12d0*sqmq-4d0*sh*th/uh)*w3sutr)

            b2usti=sqmq/sqmh**2*(2d0*sh*th*(th+2d0*uh)/(uh+th)**2*

     &      (w1si-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2si+

     &      w3usti)+uh2*(2d0*sqmq/(uh+th)**2-0.5d0/(uh+th))*

     &      (w2si-w2hi)+0.5d0*sh*th/uh*(w2hi-2d0*w2si)+0.125d0*

     &      (uh-12d0*sqmq-4d0*sh*th/uh)*w3suti)

            b2utsr=sqmq/sqmh**2*(uh*(sh-uh)/(uh+sh)+2d0*th*sh*

     &      (sh+2d0*uh)/(uh+sh)**2*(w1tr-w1hr)+(sqmq-uh/4d0)*

     &      (0.5d0*w2ur+0.5d0*w2hr-w2tr+w3utsr)+uh2*(2d0*sqmq/

     &      (uh+sh)**2-0.5d0/(uh+sh))*(w2tr-w2hr)+0.5d0*th*sh/uh*

     &      (w2hr-2d0*w2tr)+0.125d0*(uh-12d0*sqmq-4d0*th*sh/uh)*w3tusr)

            b2utsi=sqmq/sqmh**2*(2d0*th*sh*(sh+2d0*uh)/(uh+sh)**2*

     &      (w1ti-w1hi)+(sqmq-uh/4d0)*(0.5d0*w2ui+0.5d0*w2hi-w2ti+

     &      w3utsi)+uh2*(2d0*sqmq/(uh+sh)**2-0.5d0/(uh+sh))*

     &      (w2ti-w2hi)+0.5d0*th*sh/uh*(w2hi-2d0*w2ti)+0.125d0*

     &      (uh-12d0*sqmq-4d0*th*sh/uh)*w3tusi)

            b4stur=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*

     &      (w2sr-w2hr+w3stur))

            b4stui=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2si-w2hi+w3stui)

            b4tusr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*

     &      (w2tr-w2hr+w3tusr))

            b4tusi=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ti-w2hi+w3tusi)

            b4ustr=0.25d0*epsh*(-2d0/3d0+0.25d0*(epsh-1d0)*

     &      (w2ur-w2hr+w3ustr))

            b4usti=0.25d0*epsh*0.25d0*(epsh-1d0)*(w2ui-w2hi+w3usti)

            a2stur=a2stur+b2stur+b2sutr

            a2stui=a2stui+b2stui+b2suti

            a2ustr=a2ustr+b2ustr+b2utsr

            a2usti=a2usti+b2usti+b2utsi

            a2tusr=a2tusr+b2tusr+b2tsur

            a2tusi=a2tusi+b2tusi+b2tsui

            a4stur=a4stur+b4stur+b4ustr+b4tusr

            a4stui=a4stui+b4stui+b4usti+b4tusi

 1170     CONTINUE

          facgh=comfac*faca*3d0/(128d0*paru(1)**2)*aem/xw*as**3*

     &    sqmh/sqmw*sqmh**3/(sh*th*uh)*(a2stur**2+a2stui**2+a2ustr**2+

     &    a2usti**2+a2tusr**2+a2tusi**2+a4stur**2+a4stui**2)

          facgh=facgh*wids(25,2)

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1180

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facgh

 1180     CONTINUE


        ELSEIF(isub.EQ.114.OR.isub.EQ.115) THEN

C...g + g -> gamma + gamma or g + g -> g + gamma

          a0stur=0d0

          a0stui=0d0

          a0tsur=0d0

          a0tsui=0d0

          a0utsr=0d0

          a0utsi=0d0

          a1stur=0d0

          a1stui=0d0

          a2stur=0d0

          a2stui=0d0

          alst=log(-sh/th)

          alsu=log(-sh/uh)

          altu=log(th/uh)

          imax=2*mstp(1)

          IF(mstp(38).GE.1.AND.mstp(38).LE.8) imax=mstp(38)

          DO 1190 i=1,imax

            ei=kchg(iabs(i),1)/3d0

            eiwt=ei**2

            IF(isub.EQ.115) eiwt=ei

            sqmq=pmas(i,1)**2

            epss=4d0*sqmq/sh

            epst=4d0*sqmq/th

            epsu=4d0*sqmq/uh

            IF((mstp(38).GE.1.AND.mstp(38).LE.8).OR.epss.LT.1.d-4) THEN

              b0stur=1d0+(th-uh)/sh*altu+0.5d0*(th2+uh2)/sh2*(altu**2+

     &        paru(1)**2)

              b0stui=0d0

              b0tsur=1d0+(sh-uh)/th*alsu+0.5d0*(sh2+uh2)/th2*alsu**2

              b0tsui=-paru(1)*((sh-uh)/th+(sh2+uh2)/th2*alsu)

              b0utsr=1d0+(sh-th)/uh*alst+0.5d0*(sh2+th2)/uh2*alst**2

              b0utsi=-paru(1)*((sh-th)/uh+(sh2+th2)/uh2*alst)

              b1stur=-1d0

              b1stui=0d0

              b2stur=-1d0

              b2stui=0d0

            ELSE

              CALL pywaux(1,epss,w1sr,w1si)

              CALL pywaux(1,epst,w1tr,w1ti)

              CALL pywaux(1,epsu,w1ur,w1ui)

              CALL pywaux(2,epss,w2sr,w2si)

              CALL pywaux(2,epst,w2tr,w2ti)

              CALL pywaux(2,epsu,w2ur,w2ui)

              CALL pyi3au(epss,th/uh,y3stur,y3stui)

              CALL pyi3au(epss,uh/th,y3sutr,y3suti)

              CALL pyi3au(epst,sh/uh,y3tsur,y3tsui)

              CALL pyi3au(epst,uh/sh,y3tusr,y3tusi)

              CALL pyi3au(epsu,sh/th,y3ustr,y3usti)

              CALL pyi3au(epsu,th/sh,y3utsr,y3utsi)

              b0stur=1d0+(1d0+2d0*th/sh)*w1tr+(1d0+2d0*uh/sh)*w1ur+

     &        0.5d0*((th2+uh2)/sh2-epss)*(w2tr+w2ur)-

     &        0.25d0*epst*(1d0-0.5d0*epss)*(y3sutr+y3tusr)-

     &        0.25d0*epsu*(1d0-0.5d0*epss)*(y3stur+y3utsr)+

     &        0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+

     &        0.5d0*epst*epsu)*(y3tsur+y3ustr)

              b0stui=(1d0+2d0*th/sh)*w1ti+(1d0+2d0*uh/sh)*w1ui+

     &        0.5d0*((th2+uh2)/sh2-epss)*(w2ti+w2ui)-

     &        0.25d0*epst*(1d0-0.5d0*epss)*(y3suti+y3tusi)-

     &        0.25d0*epsu*(1d0-0.5d0*epss)*(y3stui+y3utsi)+

     &        0.25d0*(-2d0*(th2+uh2)/sh2+4d0*epss+epst+epsu+

     &        0.5d0*epst*epsu)*(y3tsui+y3usti)

              b0tsur=1d0+(1d0+2d0*sh/th)*w1sr+(1d0+2d0*uh/th)*w1ur+

     &        0.5d0*((sh2+uh2)/th2-epst)*(w2sr+w2ur)-

     &        0.25d0*epss*(1d0-0.5d0*epst)*(y3tusr+y3sutr)-

     &        0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsur+y3ustr)+

     &        0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+

     &        0.5d0*epss*epsu)*(y3stur+y3utsr)

              b0tsui=(1d0+2d0*sh/th)*w1si+(1d0+2d0*uh/th)*w1ui+

     &        0.5d0*((sh2+uh2)/th2-epst)*(w2si+w2ui)-

     &        0.25d0*epss*(1d0-0.5d0*epst)*(y3tusi+y3suti)-

     &        0.25d0*epsu*(1d0-0.5d0*epst)*(y3tsui+y3usti)+

     &        0.25d0*(-2d0*(sh2+uh2)/th2+4d0*epst+epss+epsu+

     &        0.5d0*epss*epsu)*(y3stui+y3utsi)

              b0utsr=1d0+(1d0+2d0*th/uh)*w1tr+(1d0+2d0*sh/uh)*w1sr+

     &        0.5d0*((th2+sh2)/uh2-epsu)*(w2tr+w2sr)-

     &        0.25d0*epst*(1d0-0.5d0*epsu)*(y3ustr+y3tsur)-

     &        0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsr+y3stur)+

     &        0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+

     &        0.5d0*epst*epss)*(y3tusr+y3sutr)

              b0utsi=(1d0+2d0*th/uh)*w1ti+(1d0+2d0*sh/uh)*w1si+

     &        0.5d0*((th2+sh2)/uh2-epsu)*(w2ti+w2si)-

     &        0.25d0*epst*(1d0-0.5d0*epsu)*(y3usti+y3tsui)-

     &        0.25d0*epss*(1d0-0.5d0*epsu)*(y3utsi+y3stui)+

     &        0.25d0*(-2d0*(th2+sh2)/uh2+4d0*epsu+epst+epss+

     &        0.5d0*epst*epss)*(y3tusi+y3suti)

              b1stur=-1d0-0.25d0*(epss+epst+epsu)*(w2sr+w2tr+w2ur)+

     &        0.25d0*(epsu+0.5d0*epss*epst)*(y3sutr+y3tusr)+

     &        0.25d0*(epst+0.5d0*epss*epsu)*(y3stur+y3utsr)+

     &        0.25d0*(epss+0.5d0*epst*epsu)*(y3tsur+y3ustr)

              b1stui=-0.25d0*(epss+epst+epsu)*(w2si+w2ti+w2ui)+

     &        0.25d0*(epsu+0.5d0*epss*epst)*(y3suti+y3tusi)+

     &        0.25d0*(epst+0.5d0*epss*epsu)*(y3stui+y3utsi)+

     &        0.25d0*(epss+0.5d0*epst*epsu)*(y3tsui+y3usti)

              b2stur=-1d0+0.125d0*epss*epst*(y3sutr+y3tusr)+

     &        0.125d0*epss*epsu*(y3stur+y3utsr)+

     &        0.125d0*epst*epsu*(y3tsur+y3ustr)

              b2stui=0.125d0*epss*epst*(y3suti+y3tusi)+

     &        0.125d0*epss*epsu*(y3stui+y3utsi)+

     &        0.125d0*epst*epsu*(y3tsui+y3usti)

            ENDIF

            a0stur=a0stur+eiwt*b0stur

            a0stui=a0stui+eiwt*b0stui

            a0tsur=a0tsur+eiwt*b0tsur

            a0tsui=a0tsui+eiwt*b0tsui

            a0utsr=a0utsr+eiwt*b0utsr

            a0utsi=a0utsi+eiwt*b0utsi

            a1stur=a1stur+eiwt*b1stur

            a1stui=a1stui+eiwt*b1stui

            a2stur=a2stur+eiwt*b2stur

            a2stui=a2stui+eiwt*b2stui

 1190     CONTINUE

          asqsum=a0stur**2+a0stui**2+a0tsur**2+a0tsui**2+a0utsr**2+

     &    a0utsi**2+4d0*a1stur**2+4d0*a1stui**2+a2stur**2+a2stui**2

          facgg=comfac*faca/(16d0*paru(1)**2)*as**2*aem**2*asqsum

          facgp=comfac*faca*5d0/(192d0*paru(1)**2)*as**3*aem*asqsum

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1200

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          IF(isub.EQ.114) sigh(nchn)=0.5d0*facgg

          IF(isub.EQ.115) sigh(nchn)=facgp

 1200     CONTINUE


        ELSEIF(isub.EQ.116) THEN

C...g + g -> gamma + Z0


        ELSEIF(isub.EQ.117) THEN

C...g + g -> Z0 + Z0


        ELSEIF(isub.EQ.118) THEN

C...g + g -> W+ + W-


        ENDIF


C...G: 2 -> 3, tree diagrams


      ELSEIF(isub.LE.140) THEN

        IF(isub.EQ.121) THEN

C...g + g -> Q + Qbar + h0

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1210

          ia=kfpr(isubsv,2)

          pmf=pmas(ia,1)

          facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*

     &    (0.5d0*pmf/pmas(24,1))**2

          IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) facqqh=

     &    facqqh*(log(max(4d0,parp(37)**2*pmf**2/paru(117)**2))/

     &    log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

          wid2=1d0

          IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)

          facqqh=facqqh*wid2

          IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

            ikfi=1

            IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2

            IF(ia.GT.10) ikfi=3

            facqqh=facqqh*paru(150+10*ihigg+ikfi)**2

          ENDIF

          CALL pyqqbh(wtqqbh)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqqh*wtqqbh*facbw

 1210     CONTINUE


        ELSEIF(isub.EQ.122) THEN

C...q + qbar -> Q + Qbar + h0

          ia=kfpr(isubsv,2)

          pmf=pmas(ia,1)

          facqqh=comfac*(4d0*paru(1)*aem/xw)*(4d0*paru(1)*as)**2*

     &    (0.5d0*pmf/pmas(24,1))**2

          IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) facqqh=

     &    facqqh*(log(max(4d0,parp(37)**2*pmf**2/paru(117)**2))/

     &    log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

          wid2=1d0

          IF(ia.EQ.6.OR.ia.EQ.7.OR.ia.EQ.8) wid2=wids(ia,1)

          facqqh=facqqh*wid2

          IF(mstp(4).GE.1.OR.ihigg.GE.2) THEN

            ikfi=1

            IF(ia.LE.10.AND.mod(ia,2).EQ.0) ikfi=2

            IF(ia.GT.10) ikfi=3

            facqqh=facqqh*paru(150+10*ihigg+ikfi)**2

          ENDIF

          CALL pyqqbh(wtqqbh)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          DO 1220 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 1220

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqqh*wtqqbh*facbw

 1220     CONTINUE


        ELSEIF(isub.EQ.123) THEN

C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as

C...inner process)

          facnor=comfac*(4d0*paru(1)*aem/(xw*xw1))**3*sqmz/32d0

          IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*

     &    paru(154+10*ihigg)**2

          facprp=1d0/((vint(215)-vint(204)**2)*

     &    (vint(216)-vint(209)**2))**2

          faczz1=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)

          faczz2=facnor*facprp*vint(217)*vint(218)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          DO 1240 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1240

            ia=iabs(i)

            DO 1230 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1230

              ja=iabs(j)

              ei=kchg(ia,1)*isign(1,i)/3d0

              ai=sign(1d0,kchg(ia,1)+0.5d0)*isign(1,i)

              vi=ai-4d0*ei*xwv

              ej=kchg(ja,1)*isign(1,j)/3d0

              aj=sign(1d0,kchg(ja,1)+0.5d0)*isign(1,j)

              vj=aj-4d0*ej*xwv

              faclr1=(vi**2+ai**2)*(vj**2+aj**2)+4d0*vi*ai*vj*aj

              faclr2=(vi**2+ai**2)*(vj**2+aj**2)-4d0*vi*ai*vj*aj

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=(faclr1*faczz1+faclr2*faczz2)*facbw

 1230       CONTINUE

 1240     CONTINUE


        ELSEIF(isub.EQ.124) THEN

C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as

C...inner process)

          facnor=comfac*(4d0*paru(1)*aem/xw)**3*sqmw

          IF(mstp(4).GE.1.OR.ihigg.GE.2) facnor=facnor*

     &    paru(155+10*ihigg)**2

          facprp=1d0/((vint(215)-vint(204)**2)*

     &    (vint(216)-vint(209)**2))**2

          facww=facnor*facprp*(0.5d0*taup*vint(2))*vint(219)

          CALL pywidt(kfhigg,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          facbw=(1d0/paru(1))*vint(2)*hf/((sh-sqmh)**2+hs**2)

          IF(abs(shr-pmas(kfhigg,1)).GT.parp(48)*pmas(kfhigg,2))

     &    facbw=0d0

          DO 1260 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1260

            ei=sign(1d0,dble(i))*kchg(iabs(i),1)

            DO 1250 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1250

              ej=sign(1d0,dble(j))*kchg(iabs(j),1)

              IF(ei*ej.GT.0d0) goto 1250

              faclr=vint(180+i)*vint(180+j)

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=faclr*facww*facbw

 1250       CONTINUE

 1260     CONTINUE


        ELSEIF(isub.EQ.131) THEN

C...g + g -> Z0 + q + qbar


        ENDIF


C...H: 2 -> 1, tree diagrams, non-standard model processes


      ELSEIF(isub.LE.160) THEN

        IF(isub.EQ.141) THEN

C...f + fbar -> gamma*/Z0/Z'0

          sqmzp=pmas(32,1)**2

          mint(61)=2

          CALL pywidt(32,sh,wdtp,wdte)

          hp0=aem/3d0*sh

          hp1=aem/3d0*xwc*sh

          hp2=hp1

          hs=shr*vint(117)

          hsp=shr*wdtp(0)

          faczp=4d0*comfac*3d0

          DO 1270 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1270

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei)

            vi=ai-4d0*ei*xwv

            IF(iabs(i).LT.10) THEN

              vpi=paru(123-2*mod(iabs(i),2))

              api=paru(124-2*mod(iabs(i),2))

            ELSE

              vpi=paru(127-2*mod(iabs(i),2))

              api=paru(128-2*mod(iabs(i),2))

            ENDIF

            hi0=hp0

            IF(iabs(i).LE.10) hi0=hi0*faca/3d0

            hi1=hp1

            IF(iabs(i).LE.10) hi1=hi1*faca/3d0

            hi2=hp2

            IF(iabs(i).LE.10) hi2=hi2*faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=faczp*(ei**2/sh2*hi0*hp0*vint(111)+ei*vi*

     &      (1d0-sqmz/sh)/((sh-sqmz)**2+hs**2)*(hi0*hp1+hi1*hp0)*

     &      vint(112)+ei*vpi*(1d0-sqmzp/sh)/((sh-sqmzp)**2+hsp**2)*

     &      (hi0*hp2+hi2*hp0)*vint(113)+(vi**2+ai**2)/

     &      ((sh-sqmz)**2+hs**2)*hi1*hp1*vint(114)+(vi*vpi+ai*api)*

     &      ((sh-sqmz)*(sh-sqmzp)+hs*hsp)/(((sh-sqmz)**2+hs**2)*

     &      ((sh-sqmzp)**2+hsp**2))*(hi1*hp2+hi2*hp1)*vint(115)+

     &      (vpi**2+api**2)/((sh-sqmzp)**2+hsp**2)*hi2*hp2*vint(116))

 1270     CONTINUE


        ELSEIF(isub.EQ.142) THEN

C...f + fbar' -> W'+/-

          sqmwp=pmas(34,1)**2

          CALL pywidt(34,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmwp)**2+hs**2)*3d0

          hp=aem/(24d0*xw)*sh

          DO 1290 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1290

            ia=iabs(i)

            DO 1280 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1280

              ja=iabs(j)

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1280

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 1280

              kchw=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              hi=hp*(paru(133)**2+paru(134)**2)

              IF(ia.LE.10) hi=hp*(paru(131)**2+paru(132)**2)*

     &        vckm((ia+1)/2,(ja+1)/2)*faca/3d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              hf=shr*(wdte(0,1)+wdte(0,(5-kchw)/2)+wdte(0,4))

              sigh(nchn)=hi*facbw*hf

 1280       CONTINUE

 1290     CONTINUE


        ELSEIF(isub.EQ.143) THEN

C...f + fbar' -> H+/-

          sqmhc=pmas(37,1)**2

          CALL pywidt(37,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmhc)**2+hs**2)

          hp=aem/(8d0*xw)*sh/sqmw*sh

          DO 1310 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1310

            ia=iabs(i)

            im=(mod(ia,10)+1)/2

            DO 1300 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1300

              ja=iabs(j)

              jm=(mod(ja,10)+1)/2

              IF(i*j.GT.0.OR.ia.EQ.ja.OR.im.NE.jm) goto 1300

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 1300

              IF(mod(ia,2).EQ.0) THEN

                iu=ia

                il=ja

              ELSE

                iu=ja

                il=ia

              ENDIF

              rml=pmas(il,1)**2/sh

              rmu=pmas(iu,1)**2/sh

              IF(il.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) rml=

     &        rml*(log(max(4d0,parp(37)**2*rml*sh/paru(117)**2))/

     &        log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-

     &        2d0*mstu(118)))

              hi=hp*(rml*paru(141)**2+rmu/paru(141)**2)

              IF(ia.LE.10) hi=hi*faca/3d0

              kchhc=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              hf=shr*(wdte(0,1)+wdte(0,(5-kchhc)/2)+wdte(0,4))

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=hi*facbw*hf

 1300       CONTINUE

 1310     CONTINUE


        ELSEIF(isub.EQ.144) THEN

C...f + fbar' -> R

          sqmr=pmas(40,1)**2

          CALL pywidt(40,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmr)**2+hs**2)*3d0

          hp=aem/(12d0*xw)*sh

          DO 1330 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1330

            ia=iabs(i)

            DO 1320 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1320

              ja=iabs(j)

              IF(i*j.GT.0.OR.iabs(ia-ja).NE.2) goto 1320

              hi=hp

              IF(ia.LE.10) hi=hi*faca/3d0

              hf=shr*(wdte(0,1)+wdte(0,(10-(i+j))/4)+wdte(0,4))

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=hi*facbw*hf

 1320       CONTINUE

 1330     CONTINUE


        ELSEIF(isub.EQ.145) THEN

C...q + l -> LQ (leptoquark)

          sqmlq=pmas(39,1)**2

          CALL pywidt(39,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=4d0*comfac/((sh-sqmlq)**2+hs**2)

          IF(abs(shr-pmas(39,1)).GT.parp(48)*pmas(39,2)) facbw=0d0

          hp=aem/4d0*sh

          kflqq=kfdp(mdcy(39,2),1)

          kflql=kfdp(mdcy(39,2),2)

          DO 1350 i=mmin1,mmax1

            IF(kfac(1,i).EQ.0) goto 1350

            ia=iabs(i)

            IF(ia.NE.kflqq.AND.ia.NE.iabs(kflql)) goto 1350

            DO 1340 j=mmin2,mmax2

              IF(kfac(2,j).EQ.0) goto 1340

              ja=iabs(j)

              IF(ja.NE.kflqq.AND.ja.NE.iabs(kflql)) goto 1340

              IF(ja.EQ.ia) goto 1340

              IF(i*j.NE.kflqq*kflql) goto 1340

              IF(ia.EQ.kflqq) kchlq=isign(1,i)

              IF(ja.EQ.kflqq) kchlq=isign(1,j)

              hi=hp*paru(151)

              hf=shr*(wdte(0,1)+wdte(0,(5-kchlq)/2)+wdte(0,4))

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=hi*facbw*hf

 1340       CONTINUE

 1350     CONTINUE


        ELSEIF(isub.EQ.147.OR.isub.EQ.148) THEN

C...d + g -> d* and u + g -> u* (excited quarks)

          kfqstr=kfpr(isub,1)

          kcqstr=pycomp(kfqstr)

          kfqexc=mod(kfqstr,kexcit)

          CALL pywidt(kfqstr,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=comfac/((sh-pmas(kcqstr,1)**2)**2+hs**2)

          facbw=facbw*as*paru(159)**2*sh/(3d0*paru(155)**2)

          IF(abs(shr-pmas(kcqstr,1)).GT.parp(48)*pmas(kcqstr,2))

     &    facbw=0d0

          hp=sh

          DO 1370 i=-kfqexc,kfqexc,2*kfqexc

            DO 1360 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1360

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1360

              hi=hp

              IF(i.GT.0) hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

              IF(i.LT.0) hf=shr*(wdte(0,1)+wdte(0,3)+wdte(0,4))

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=hi*facbw*hf

 1360       CONTINUE

 1370     CONTINUE


        ELSEIF(isub.EQ.149) THEN

C...g + g -> eta_techni

          CALL pywidt(38,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=comfac*0.5d0/((sh-pmas(38,1)**2)**2+hs**2)

          IF(abs(shr-pmas(38,1)).GT.parp(48)*pmas(38,2)) facbw=0d0

          hp=sh

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1380

          hi=hp*wdtp(3)

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=hi*facbw*hf

 1380     CONTINUE


        ENDIF


C...I: 2 -> 2, tree diagrams, non-standard model processes


      ELSEIF(isub.LE.200) THEN

        IF(isub.EQ.161) THEN

C...f + g -> f' + H+/- (b + g -> t + H+/- only)

C...(choice of only b and t to avoid kinematics problems)

          sqmhc=pmas(37,1)**2

          fhcq=comfac*faca*as*aem/xw*1d0/24

          DO 1400 i=mmina,mmaxa

            ia=iabs(i)

            IF(ia.NE.5) goto 1400

            sqml=pmas(ia,1)**2

            IF(ia.LE.10.AND.mstp(37).EQ.1.AND.mstp(2).GE.1) sqml=sqml*

     &      (log(max(4d0,parp(37)**2*sqml/paru(117)**2))/

     &      log(max(4d0,sh/paru(117)**2)))**(24d0/(33d0-2d0*mstu(118)))

            iua=ia+mod(ia,2)

            sqmq=pmas(iua,1)**2

            fachcq=fhcq*(sqml*paru(141)**2+sqmq/paru(141)**2)/sqmw*

     &      (sh/(sqmq-uh)+2d0*sqmq*(sqmhc-uh)/(sqmq-uh)**2+(sqmq-uh)/sh+

     &      2d0*sqmq/(sqmq-uh)+2d0*(sqmhc-uh)/(sqmq-uh)*

     &      (sqmhc-sqmq-sh)/sh)

            kchhc=isign(1,kchg(ia,1)*isign(1,i))

            DO 1390 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1390

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,1).EQ.0) goto 1390

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=fachcq*wids(37,(5-kchhc)/2)

 1390       CONTINUE

 1400     CONTINUE


        ELSEIF(isub.EQ.162) THEN

C...q + g -> LQ + lbar; LQ=leptoquark

          sqmlq=pmas(39,1)**2

          faclq=comfac*faca*paru(151)*(as*aem/6d0)*(-th/sh)*

     &    (uh2+sqmlq**2)/(uh-sqmlq)**2

          kflqq=kfdp(mdcy(39,2),1)

          DO 1420 i=mmina,mmaxa

            IF(iabs(i).NE.kflqq) goto 1420

            kchlq=isign(1,i)

            DO 1410 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1410

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1410

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=faclq*wids(39,(5-kchlq)/2)

 1410       CONTINUE

 1420     CONTINUE


        ELSEIF(isub.EQ.163) THEN

C...g + g -> LQ + LQbar; LQ=leptoquark

          sqmlq=pmas(39,1)**2

          faclq=comfac*faca*wids(39,1)*(as**2/2d0)*

     &    (7d0/48d0+3d0*(uh-th)**2/(16d0*sh2))*(1d0+2d0*sqmlq*th/

     &    (th-sqmlq)**2+2d0*sqmlq*uh/(uh-sqmlq)**2+4d0*sqmlq**2/

     &    ((th-sqmlq)*(uh-sqmlq)))

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1430

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

C...Since don't know proper colour flow, randomize between alternatives

          isig(nchn,3)=int(1.5d0+pyr(0))

          sigh(nchn)=faclq

 1430     CONTINUE


        ELSEIF(isub.EQ.164) THEN

C...q + qbar -> LQ + LQbar; LQ=leptoquark

          sqmlq=pmas(39,1)**2

          faclqa=comfac*wids(39,1)*(as**2/9d0)*

     &    (sh*(sh-4d0*sqmlq)-(uh-th)**2)/sh2

          faclqs=comfac*wids(39,1)*((paru(151)**2*aem**2/8d0)*

     &    (-sh*th-(sqmlq-th)**2)/th2+(paru(151)*aem*as/18d0)*

     &    ((sqmlq-th)*(uh-th)+sh*(sqmlq+th))/(sh*th))

          kflqq=kfdp(mdcy(39,2),1)

          DO 1440 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 1440

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=faclqa

            IF(iabs(i).EQ.kflqq) sigh(nchn)=faclqa+faclqs

 1440     CONTINUE


        ELSEIF(isub.EQ.165) THEN

C...q + qbar -> l+ + l- (including contact term for compositeness)

          zratr=xwc*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

          zrati=xwc*sh*gmmz/((sh-sqmz)**2+gmmz**2)

          kff=iabs(kfpr(isub,1))

          ef=kchg(kff,1)/3d0

          af=sign(1d0,ef+0.1d0)

          vf=af-4d0*ef*xwv

          valf=vf+af

          varf=vf-af

          fcof=1d0

          IF(kff.LE.10) fcof=3d0

          wid2=1d0

          IF(kff.EQ.6) wid2=wids(6,1)

          IF(kff.EQ.7.OR.kff.EQ.8) wid2=wids(kff,1)

          IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)

          DO 1450 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1450

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=vi+ai

            vari=vi-ai

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            IF((mstp(5).EQ.1.AND.iabs(i).LE.2).OR.mstp(5).EQ.2) THEN

              fgza=(ei*ef+vali*valf*zratr+paru(156)*sh/

     &        (aem*paru(155)**2))**2+(vali*valf*zrati)**2+

     &        (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2

            ELSE

              fgza=(ei*ef+vali*valf*zratr)**2+(vali*valf*zrati)**2+

     &        (ei*ef+vari*varf*zratr)**2+(vari*varf*zrati)**2

            ENDIF

            fgzb=(ei*ef+vali*varf*zratr)**2+(vali*varf*zrati)**2+

     &      (ei*ef+vari*valf*zratr)**2+(vari*valf*zrati)**2

            fgzab=aem**2*(fgza*uh2/sh2+fgzb*th2/sh2)

            IF((mstp(5).EQ.3.AND.iabs(i).EQ.2).OR.(mstp(5).EQ.4.AND.

     &      mod(iabs(i),2).EQ.0)) fgzab=fgzab+sh2/(2d0*paru(155)**4)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=comfac*fcoi*fcof*fgzab*wid2

 1450     CONTINUE


        ELSEIF(isub.EQ.166) THEN

C...q + q'bar -> l + nu_l (including contact term for compositeness)

          wfac=(1d0/4d0)*(aem/xw)**2*uh2/((sh-sqmw)**2+gmmw**2)

          wcifac=wfac+sh2/(4d0*paru(155)**4)

          kff=iabs(kfpr(isub,1))

          fcof=1d0

          IF(kff.LE.10) fcof=3d0

          DO 1470 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1470

            ia=iabs(i)

            DO 1460 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1460

              ja=iabs(j)

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1460

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 1460

              fcoi=1d0

              IF(ia.LE.10) fcoi=vckm((ia+1)/2,(ja+1)/2)*faca/3d0

              wid2=1d0

              IF((i.GT.0.AND.mod(i,2).EQ.0).OR.(j.GT.0.AND.

     &        mod(j,2).EQ.0)) THEN

                IF(kff.EQ.5) wid2=wids(6,2)

                IF(kff.EQ.7) wid2=wids(8,2)*wids(7,3)

                IF(kff.EQ.17) wid2=wids(18,2)*wids(17,3)

              ELSE

                IF(kff.EQ.5) wid2=wids(6,3)

                IF(kff.EQ.7) wid2=wids(8,3)*wids(7,2)

                IF(kff.EQ.17) wid2=wids(18,3)*wids(17,2)

              ENDIF

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=comfac*fcoi*fcof*wfac*wid2

              IF((mstp(5).EQ.3.AND.ia.LE.2.AND.ja.LE.2).OR.mstp(5).EQ.4)

     &        sigh(nchn)=comfac*fcoi*fcof*wcifac*wid2

 1460       CONTINUE

 1470     CONTINUE


        ELSEIF(isub.EQ.167.OR.isub.EQ.168) THEN

C...d + g -> d* and u + g -> u* (excited quarks)

          kfqstr=kfpr(isub,2)

          kcqstr=pycomp(kfqstr)

          kfqexc=mod(kfqstr,kexcit)

          facqsa=comfac*(sh/paru(155)**2)**2*(1d0-sqm4/sh)

          facqsb=comfac*0.25d0*(sh/paru(155)**2)**2*(1d0-sqm4/sh)*

     &    (1d0+sqm4/sh)*(1d0+cth)*(1d0+((sh-sqm4)/(sh+sqm4))*cth)

C...Propagators: as simulated in PYOFSH and as desired

          gmmq=pmas(kcqstr,1)*pmas(kcqstr,2)

          hbw4=gmmq/((sqm4-pmas(kcqstr,1)**2)**2+gmmq**2)

          CALL pywidt(kfqstr,sqm4,wdtp,wdte)

          gmmqc=sqrt(sqm4)*wdtp(0)

          hbw4c=gmmqc/((sqm4-pmas(kcqstr,1)**2)**2+gmmqc**2)

          facqsa=facqsa*hbw4c/hbw4

          facqsb=facqsb*hbw4c/hbw4

          DO 1490 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.6.OR.kfac(1,i).EQ.0) goto 1490

            DO 1480 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.6.OR.kfac(2,j).EQ.0) goto 1480

              IF(ia.EQ.kfqexc.AND.i.EQ.j) THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                sigh(nchn)=(4d0/3d0)*facqsa

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                sigh(nchn)=(4d0/3d0)*facqsa

              ELSEIF((ia.EQ.kfqexc.OR.ja.EQ.kfqexc).AND.i*j.GT.0) THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                IF(ja.EQ.kfqexc) isig(nchn,3)=2

                sigh(nchn)=facqsa

              ELSEIF(ia.EQ.kfqexc.AND.i.EQ.-j) THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                sigh(nchn)=(8d0/3d0)*facqsb

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                sigh(nchn)=(8d0/3d0)*facqsb

              ELSEIF(i.EQ.-j) THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                sigh(nchn)=facqsb

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                sigh(nchn)=facqsb

              ELSEIF(ia.EQ.kfqexc.OR.ja.EQ.kfqexc) THEN

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=1

                IF(ja.EQ.kfqexc) isig(nchn,3)=2

                sigh(nchn)=facqsb

              ENDIF

 1480       CONTINUE

 1490     CONTINUE


        ELSEIF(isub.EQ.191) THEN

C...q + qbar -> rho_tech0.

          sqmrht=pmas(54,1)**2

          CALL pywidt(54,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)

          IF(abs(shr-pmas(54,1)).GT.parp(48)*pmas(54,2)) facbw=0d0

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          alprht=2.91d0*(3d0/parp(144))

          hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)

          xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))

          bwzr=xwrht*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

          bwzi=xwrht*sh*gmmz/((sh-sqmz)**2+gmmz**2)

          DO 1500 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1500

            ia=iabs(i)

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=0.5d0*(vi+ai)

            vari=0.5d0*(vi-ai)

            hi=hp*((ei+vali*bwzr)**2+(vali*bwzi)**2+

     &      (ei+vari*bwzr)**2+(vari*bwzi)**2)

            IF(ia.LE.10) hi=hi*faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=hi*facbw*hf

 1500     CONTINUE


        ELSEIF(isub.EQ.192) THEN

C...q + qbar' -> rho_tech+/-.

          sqmrht=pmas(55,1)**2

          CALL pywidt(55,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=12d0*comfac/((sh-sqmrht)**2+hs**2)

          IF(abs(shr-pmas(55,1)).GT.parp(48)*pmas(55,2)) facbw=0d0

          alprht=2.91d0*(3d0/parp(144))

          hp=(1d0/6d0)*(aem**2/alprht)*(sqmrht**2/sh)*

     &    (0.25d0/xw**2)*sh**2/((sh-sqmw)**2+gmmw**2)

          DO 1520 i=mmin1,mmax1

            IF(i.EQ.0.OR.kfac(1,i).EQ.0) goto 1520

            ia=iabs(i)

            DO 1510 j=mmin2,mmax2

              IF(j.EQ.0.OR.kfac(2,j).EQ.0) goto 1510

              ja=iabs(j)

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1510

              IF((ia.LE.10.AND.ja.GT.10).OR.(ia.GT.10.AND.ja.LE.10))

     &        goto 1510

              kchr=(kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j))/3

              hf=shr*(wdte(0,1)+wdte(0,(5-kchr)/2)+wdte(0,4))

              hi=hp

              IF(ia.LE.10) hi=hi*vckm((ia+1)/2,(ja+1)/2)*faca/3d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=hi*facbw*hf

 1510       CONTINUE

 1520     CONTINUE


        ELSEIF(isub.EQ.193) THEN

C...q + qbar -> omega_tech0.

          sqmomt=pmas(56,1)**2

          CALL pywidt(56,sh,wdtp,wdte)

          hs=shr*wdtp(0)

          facbw=12d0*comfac/((sh-sqmomt)**2+hs**2)

          IF(abs(shr-pmas(56,1)).GT.parp(48)*pmas(56,2)) facbw=0d0

          hf=shr*(wdte(0,1)+wdte(0,2)+wdte(0,4))

          alprht=2.91d0*(3d0/parp(144))

          hp=(1d0/6d0)*(aem**2/alprht)*(sqmomt**2/sh)*

     &    (2d0*parp(143)-1d0)**2

          bwzr=(0.5d0/(1d0-xw))*sh*(sh-sqmz)/((sh-sqmz)**2+gmmz**2)

          bwzi=(0.5d0/(1d0-xw))*sh*gmmz/((sh-sqmz)**2+gmmz**2)

          DO 1530 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1530

            ia=iabs(i)

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=0.5d0*(vi+ai)

            vari=0.5d0*(vi-ai)

            hi=hp*((ei-vali*bwzr)**2+(vali*bwzi)**2+

     &      (ei-vari*bwzr)**2+(vari*bwzi)**2)

            IF(ia.LE.10) hi=hi*faca/3d0

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=hi*facbw*hf

 1530     CONTINUE


        ELSEIF(isub.EQ.194) THEN

C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.

          sqmrht=pmas(54,1)**2

          CALL pywidt(54,sh,wdtp,wdte)

          hsrht=shr*wdtp(0)

          bwrhtr=sqmrht**2*(sh-sqmrht)/((sh-sqmrht)**2+hsrht**2)

          bwrhti=sqmrht**2*hsrht/((sh-sqmrht)**2+hsrht**2)

          xwrht=(1d0-2d0*xw)/(4d0*xw*(1d0-xw))

          sqmomt=pmas(56,1)**2

          CALL pywidt(56,sh,wdtp,wdte)

          hsomt=shr*wdtp(0)

          bwomtr=sqmomt**2*(sh-sqmomt)/((sh-sqmomt)**2+hsomt**2)

          bwomti=sqmomt**2*hsomt/((sh-sqmomt)**2+hsomt**2)

          xwomt=0.5d0/(1d0-xw)

          kff=iabs(kfpr(isub,1))

          ef=kchg(kff,1)/3d0

          af=sign(1d0,ef+0.1d0)

          vf=af-4d0*ef*xwv

          valf=0.5d0*(vf+af)

          varf=0.5d0*(vf-af)

          fcof=1d0

          IF(kff.LE.10) fcof=3d0

          wid2=1d0

          IF(kff.GE.6.AND.kff.LE.8) wid2=wids(kff,1)

          IF(kff.EQ.17.OR.kff.EQ.18) wid2=wids(kff,1)

          alprht=2.91d0*(3d0/parp(144))

          factc=comfac*(aem**2/(alprht*sh2))**2*fcof*wid2

          bwz=sh/(sh-sqmz)

          aleftf=ef+valf*xwrht*bwz

          arighf=ef+varf*xwrht*bwz

          bleftf=(ef-valf*xwomt*bwz)*(2d0*parp(143)-1d0)

          brighf=(ef-varf*xwomt*bwz)*(2d0*parp(143)-1d0)

          DO 1540 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1540

            ei=kchg(iabs(i),1)/3d0

            ai=sign(1d0,ei+0.1d0)

            vi=ai-4d0*ei*xwv

            vali=0.5d0*(vi+ai)

            vari=0.5d0*(vi-ai)

            fcoi=1d0

            IF(iabs(i).LE.10) fcoi=faca/3d0

            alefti=ei+vali*xwrht*bwz

            arighi=ei+vari*xwrht*bwz

            blefti=(ei-vali*xwomt*bwz)*(2d0*parp(143)-1d0)

            brighi=(ei-vari*xwomt*bwz)*(2d0*parp(143)-1d0)

            difll=(alefti*aleftf*bwrhtr+blefti*bleftf*bwomtr)**2+

     &      (alefti*aleftf*bwrhti+blefti*bleftf*bwomti)**2

            difrr=(arighi*arighf*bwrhtr+brighi*brighf*bwomtr)**2+

     &      (arighi*arighf*bwrhti+brighi*brighf*bwomti)**2

            diflr=(alefti*arighf*bwrhtr+blefti*brighf*bwomtr)**2+

     &      (alefti*arighf*bwrhti+blefti*brighf*bwomti)**2

            difrl=(arighi*aleftf*bwrhtr+brighi*bleftf*bwomtr)**2+

     &      (arighi*aleftf*bwrhti+brighi*bleftf*bwomti)**2

            facsig=(difll+difrr)*uh2+(diflr+difrl)*th2

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=factc*fcoi*facsig

 1540     CONTINUE


        ENDIF


CMRENNA++

C...J: 2 -> 2, tree diagrams, SUSY processes


      ELSEIF(isub.LE.210) THEN

        IF(isub.EQ.201) THEN

C...f + fbar -> e_L + e_Lbar

          comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)

          DO 1570 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1570

            ei=kchg(iabs(i),1)/3d0

            tt3i=sign(1d0,ei+1d-6)/2d0

            ej=-1d0

            tt3j=-1d0/2d0

            fcol=1d0

C...Color factor for e+ e-

            IF(ia.GE.11) fcol=3d0

            IF(ilr.EQ.1) THEN

              xlq=2d0*(tt3j-ej*xw)*sfmix(kfid,3)**2

              xrq=2d0*(-ej*xw)*sfmix(kfid,4)**2

            ELSEIF(ilr.EQ.0) THEN

              xlq=2d0*(tt3j-ej*xw)*sfmix(kfid,1)**2

              xrq=2d0*(-ej*xw)*sfmix(kfid,2)**2

            ENDIF

            xlf=2d0*(tt3i-ei*xw)

            xrf=2d0*(-ei*xw)

            taa=0.5d0*(ei*ej)**2

            tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2

            tzz=tzz/((1d0-sqmz/sh)**2+sqmz*zwid/sh**2)

            taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)

            taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)

            tnn=0.0d0

            tan=0.0d0

            tzn=0.0d0

            IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN

              IF(ilr.EQ.0) THEN

                a1=sfmix(kfid,1)

                a2=sfmix(kfid,2)

              ELSE

                a1=sfmix(kfid,3)

                a2=sfmix(kfid,4)

              ENDIF

              fac2=sqrt(2d0)

              tnn1=0d0

              tnn2=0d0

              tnn3=0d0

              DO 1560 ii=1,4

                dk=1d0/(th-smz(ii)**2)

                flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-2d0*ei)*

     &          zmix(ii,1))/2d0

                frek=fac2*tanw*ei*zmix(ii,1)

                tnn1=tnn1+flek**2*dk

                tnn2=tnn2+frek**2*dk

                DO 1550 jj=1,4

                  dl=1d0/(th-smz(jj)**2)

                  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-2d0*ej)*

     &            zmix(jj,1))/2d0

                  frel=fac2*tanw*ej*zmix(jj,1)

                  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)

 1550           CONTINUE

 1560         CONTINUE

              tnn=(uh*th - sqm3*sqm4)*(a1**4*tnn1**2+a2**4*tnn2**2)

              tnn=(tnn+2d0*sh*a1**2*a2**2*tnn3)/4d0

              tzn=(uh*th-sqm3*sqm4)*(xlq+xrq)/2d0*

     &        (tnn1*xlq+tnn2*xrq)/2d0

              tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*

     &        (1d0-sqmz/sh)/sh

              tzn=tzn/xw**2/(1d0-xw)

              tan=(uh*th-sqm3*sqm4)/sh*(a1**2*tnn1+a2**2*tnn2)/xw

            ENDIF

            facqq1=comfac*aem**2*(taa+tzz+taz)*fcol*4d0/3d0

            facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh**2

            facqq2=comfac*aem**2*(tnn+tzn+tan)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq1+facqq2

 1570     CONTINUE


        ELSEIF(isub.EQ.203) THEN

C...f + fbar -> e_L + e_Rbar

          DO 1600 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1600

            ei=kchg(iabs(i),1)/3d0

            tt3i=sign(1d0,ei)/2d0

            ej=-1

            tt3j=-1d0/2d0

            fcol=1d0

C...Asymmetry factor for e1+ e2- vs. e2+ e1-

            pasy=0d0

            IF(ia.GE.11.AND.kfid.EQ.ia) THEN

              IF(abs(mint(21)).EQ.kfpr(isub,1)) THEN

                pasy=-isign(1,mint(21))

              ELSE

                pasy=-isign(1,mint(22))

              ENDIF

            ENDIF

C...Color factor for e+ e-

            IF(ia.GE.11) fcol=3d0

            a1=sfmix(kfid,1)**2

            a2=sfmix(kfid,2)**2

            xlq=2d0*(tt3j-ej*xw)

            xrq=2d0*(-ej*xw)

            xlf=2d0*(tt3i-ei*xw)

            xrf=2d0*(-ei*xw)

            tzz=(xlf**2-xrf**2)*(xlq-xrq)**2/64d0/xw**2/(1d0-

     &      xw)**2*a1*a2

            tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)

            tnn=0.0d0

            tzn=0.0d0

            IF(ia.GE.11.AND.ia.LE.18.AND.kfid.EQ.ia) THEN

              fac2=sqrt(2d0)

              tnn1=0d0

              tnn2=0d0

              tnn3=0d0

              DO 1590 ii=1,4

                dk=1d0/(th-smz(ii)**2)

                flek=-fac2*(tt3i*zmix(ii,2)-tanw*(tt3i-ei)*

     &          zmix(ii,1))

                frek=fac2*tanw*ei*zmix(ii,1)

                tnn1=tnn1+flek**2*dk

                tnn2=tnn2+frek**2*dk

                DO 1580 jj=1,4

                  dl=1d0/(th-smz(jj)**2)

                  flel=-fac2*(tt3j*zmix(jj,2)-tanw*(tt3j-ej)*

     &            zmix(jj,1))

                  frel=fac2*tanw*ej*zmix(jj,1)

                  tnn3=tnn3+flek*frek*flel*frel*dk*dl*smz(ii)*smz(jj)

 1580           CONTINUE

 1590         CONTINUE

              tnn=(uh*th-sqm3*sqm4)*a1*a2*(tnn2**2-tnn1**2)

              tnn=(tnn+sh*(a2-a1)*pasy*tnn3)/4d0

              tzn=(uh*th-sqm3*sqm4)*a1*a2

              tzn=tzn*(xlf-xrf)*(xlq*tnn1+xrq*tnn2)/4d0/(1d0-xw)

              tzn=tzn/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*

     &        (1d0-sqmz/sh)/sh

            ENDIF

            facqq1=comfac*aem**2*tzz*fcol*4d0/3d0*(uh*th-sqm3*sqm4)/sh2

            facqq2=comfac*aem**2/xw**2*(tnn+tzn)

            facqq=2d0*(facqq1+facqq2)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),2)*

     &      wids(pycomp(kfpr(isubsv,2)),3)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=2

            sigh(nchn)=facqq*wids(pycomp(kfpr(isubsv,1)),3)*

     &      wids(pycomp(kfpr(isubsv,2)),2)

 1600     CONTINUE


        ELSEIF(isub.EQ.210) THEN

C...q + qbar' -> W*- > ~l_L + ~nu_L

          fac0=rkf*comfac*aem**2/xw**2/12d0

          fac1=(th*uh-sqm3*sqm4)/((sh-sqmw)**2+wwid**2*sqmw)

          DO 1620 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 1620

            DO 1610 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 1610

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1610

              fckm=3d0

              IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)

              kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)

              kchw=2

              IF(kchsum.LT.0) kchw=3

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=fac0*fac1*fckm*wids(pycomp(kfpr(isubsv,1)),

     &        5-kchw)*wids(pycomp(kfpr(isubsv,2)),kchw)

 1610       CONTINUE

 1620     CONTINUE

        ENDIF


      ELSEIF(isub.LE.220) THEN

        IF(isub.EQ.213) THEN

C...f + fbar -> ~nu_L + ~nu_Lbar

          comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)

          fac0=rkf*comfac/3d0*aem**2

          fac1=xw*(1d0-xw)

          propz=(sh-sqmz)**2+zwid**2*sqmz

          xll=0.5d0

          xlr=0.0d0

          DO 1630 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1630

            ei=kchg(iabs(i),1)/3d0

            fcol=1d0

C...Color factor for e+ e-

            IF(ia.GE.11) fcol=3d0

            xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0

            xrq=-ei*xw

            facqq1=(xlq**2+xrq**2)*(xll+xlr)**2/fac1**2/propz

     &      *(uh*th-sqm3*sqm4)

            tzc=0.0d0

            IF(ia.GE.11.AND.kfid.EQ.ia+1) THEN

              tzc=vmix(1,1)**2/(th-smw(1)**2)+vmix(2,1)**2/

     &        (th-smw(2)**2)

              tcc=tzc**2

              tzc=tzc/(1d0-xw)*(sh-sqmz)/propz+tcc

            ENDIF

            facqq2=rkf*(uh*th-sqm3*sqm4)/4d0*tzc*comfac*aem**2/xw**2

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq1*fcol*fac0+facqq2

 1630     CONTINUE


        ELSEIF(isub.EQ.216) THEN

C...q + qbar -> ~chi0_1 + ~chi0_1

          IF(izid1.EQ.izid2) THEN

            comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)

          ELSE

            comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*

     &      wids(pycomp(kfpr(isubsv,2)),2)

          ENDIF

          facgg1=comfac*aem**2/3d0/xw**2

          IF(izid1.EQ.izid2) facgg1=facgg1/2d0

          zm12=sqm3

          zm22=sqm4

          sr2=sqrt(2d0)

          tanw=sqrt(xw/(1d0-xw))

          wu2 = (uh-zm12)*(uh-zm22)/sh2

          wt2 = (th-zm12)*(th-zm22)/sh2

          xs2 = smz(izid1)*smz(izid2)/sh

          propz2 = (sh-sqmz)**2 + sqmz*zwid**2

          reprpz = (sh-sqmz)/propz2

          olpp=(-zmix(izid1,3)*zmix(izid2,3)+

     &    zmix(izid1,4)*zmix(izid2,4))/2d0

          DO 1640 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1640

            ei=kchg(iabs(i),1)/3d0

            fcol=1d0

            IF(abs(i).GE.11) fcol=3d0

            xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0

            xrq=-ei*xw

            xlq=xlq/(1d0-xw)

            xrq=xrq/(1d0-xw)

C...Factored out sqrt(2)

            fr1=tanw*ei*zmix(izid1,1)

            fr2=tanw*ei*zmix(izid2,1)

            fl1=-(sign(1d0,ei)*zmix(izid1,2)-tanw*

     &      (sign(1d0,ei)-2d0*ei)*zmix(izid1,1))/2d0

            fl2=-(sign(1d0,ei)*zmix(izid2,2)-tanw*

     &      (sign(1d0,ei)-2d0*ei)*zmix(izid2,1))/2d0

            fr12=fr1**2

            fr22=fr2**2

            fl12=fl1**2

            fl22=fl2**2

            xml2=pmas(pycomp(ksusy1+iabs(i)),1)**2

            xmr2=pmas(pycomp(ksusy2+iabs(i)),1)**2

            facs=olpp**2*(xlq**2+xrq**2)*(wu2+wt2-2d0*xs2)*(sh2/propz2)

            fact=fl12*fl22*(wt2*sh2/(th-xml2)**2+wu2*sh2/(uh-xml2)**2-

     &      2d0*xs2*sh2/(th-xml2)/(uh-xml2))

            facu=fr12*fr22*(wt2*sh2/(th-xmr2)**2+wu2*sh2/(uh-xmr2)**2-

     &      2d0*xs2*sh2/(th-xmr2)/(uh-xmr2))

            facst=2d0*reprpz*olpp*xlq*fl1*fl2*( (wt2-xs2)*sh2/

     &      (th-xml2) + (wu2-xs2)*sh2/(uh-xml2) )

            facsu=-2d0*reprpz*olpp*xrq*fr1*fr2*( (wt2-xs2)*sh2/

     &      (th-xmr2) + (wu2-xs2)*sh2/(uh-xmr2) )

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facgg1*fcol*(facs+fact+facu+facst+facsu)

 1640     CONTINUE

        ENDIF


      ELSEIF(isub.LE.230) THEN

        IF(isub.EQ.226) THEN

C...f + fbar -> ~chi+_1 + ~chi-_1

          facgg1=comfac*aem**2/3d0/xw**2

          zm12=sqm3

          zm22=sqm4

          wu2 = (uh-zm12)*(uh-zm22)/sh2

          wt2 = (th-zm12)*(th-zm22)/sh2

          ws2 = smw(izid1)*smw(izid2)/sh

          propz2 = (sh-sqmz)**2 + sqmz*zwid**2

          reprpz = (sh-sqmz)/propz2

          diff=0d0

          IF(izid1.EQ.izid2) diff=1d0

          DO 1650 i=mmina,mmaxa

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1650

            ei=kchg(iabs(i),1)/3d0

            fcol=1d0

            IF(iabs(i).GE.11) fcol=3d0

            xlq=(sign(1d0,ei)-2d0*ei*xw)/2d0

            xrq=-ei*xw

            xlq=xlq/(1d0-xw)

            xrq=xrq/(1d0-xw)

            xlq2=xlq**2

            xrq2=xrq**2

            olp=-vmix(izid1,1)*vmix(izid2,1)-

     &      vmix(izid1,2)*vmix(izid2,2)/2d0+xw*diff

            orp=-umix(izid1,1)*umix(izid2,1)-

     &      umix(izid1,2)*umix(izid2,2)/2d0+xw*diff

            orp2=orp**2

            olp2=olp**2

C...u-type quark - d-type squark

            IF(mod(i,2).EQ.0) THEN

              fact0 = umix(izid1,1)*umix(izid2,1)

              xml2=pmas(pycomp(ksusy1+iabs(i)-1),1)**2

C...d-type quark - u-type squark

            ELSE

              fact0 = vmix(izid1,1)*vmix(izid2,1)

              xml2=pmas(pycomp(ksusy1+iabs(i)+1),1)**2

            ENDIF

            faca=2d0*xw**2*diff*(wt2+wu2+2d0*abs(ws2))*ei**2

            facz=0.5d0*((xlq2+xrq2)*(olp2+orp2)*(wt2+wu2)+

     &      4d0*(xlq2+xrq2)*olp*orp*ws2-(xlq2-xrq2)*(olp2-orp2)*

     &      (wu2-wt2))*sh2/propz2

            fact=fact0**2/4d0*wt2*sh2/(th-xml2)**2

            facaz=xw*reprpz*diff*( (xlq+xrq)*(olp+orp)*(wu2+

     &      wt2+2d0*abs(ws2))-(xlq-xrq)*(olp-orp)*(wu2-wt2) )*sh*(-ei)

            facta=xw*diff/(th-xml2)*(wt2+abs(ws2))*sh*fact0*(-ei)

            factz=reprpz/(th-xml2)*xlq*fact0*(olp*wt2+orp*ws2)*sh2

            facsum=facgg1*(faca+facaz+facz+fact+facta+factz)*fcol

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            IF(izid1.EQ.izid2) THEN

              sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),1)

            ELSE

              sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),3)*

     &        wids(pycomp(kfpr(isubsv,1)),2)

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=-i

              isig(nchn,3)=2

              sigh(nchn)=facsum*wids(pycomp(kfpr(isubsv,1)),2)*

     &        wids(pycomp(kfpr(isubsv,1)),3)

            ENDIF

 1650     CONTINUE


        ELSEIF(isub.EQ.229) THEN

C...q + qbar' -> ~chi0_1 + ~chi+-_1

          facgg1=comfac*aem**2/6d0/xw**2

          tanw = sqrt(xw/(1d0-xw))

          zm12=sqm3

          zm22=sqm4

          zmu2  = pmas(pycomp(ksusy1+2),1)**2

          zmd2  = pmas(pycomp(ksusy1+1),1)**2

          wu2 = (uh-zm12)*(uh-zm22)/sh2

          wt2 = (th-zm12)*(th-zm22)/sh2

          ws2 = smw(izid1)*smz(izid2)/sh

          rt2i = 1d0/sqrt(2d0)

          propw = ((sh-sqmw)**2+wwid**2*sqmw)

          ol=-rt2i*zmix(izid2,4)*vmix(izid1,2)+

     &    zmix(izid2,2)*vmix(izid1,1)

          or= rt2i*zmix(izid2,3)*umix(izid1,2)+

     &    zmix(izid2,2)*umix(izid1,1)

          ol2=ol**2

          or2=or**2

          cross=2d0*ol*or

          facst0=umix(izid1,1)

          facsu0=vmix(izid1,1)

          facsu0=facsu0*(0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)

          facst0=facst0*(-0.5d0*zmix(izid2,2)+tanw*zmix(izid2,1)/6d0)

          fact0=facst0**2

          facu0=facsu0**2

          factu0=facsu0*facst0

          facst = -2d0*(sh-sqmw)/propw/(th-zmd2)*(wt2*sh2*or

     &    + sh2*ws2*ol)*facst0

          facsu =  2d0*(sh-sqmw)/propw/(uh-zmu2)*(wu2*sh2*ol

     &    + sh2*ws2*or)*facsu0

          fact = wt2*sh2/(th-zmd2)**2*fact0

          facu = wu2*sh2/(uh-zmu2)**2*facu0

          factu = -2d0*ws2*sh2/(th-zmd2)/(uh-zmu2)*factu0

          facw = (or2*wt2+ol2*wu2+cross*ws2)/propw*sh2

          facgg1=facgg1*(facw+fact+factu+facu+facsu+facst)

          DO 1670 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.20.OR.kfac(1,i).EQ.0) goto 1670

            DO 1660 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.20.OR.kfac(2,j).EQ.0) goto 1660

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1660

              fckm=3d0

              IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)

              kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)

              kchw=2

              IF(kchsum.LT.0) kchw=3

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facgg1*fckm*wids(pycomp(kfpr(isubsv,1)),2)*

     &        wids(pycomp(kfpr(isubsv,2)),kchw)

 1660       CONTINUE

 1670     CONTINUE

        ENDIF


      ELSEIF(isub.LE.240) THEN

        IF(isub.EQ.237) THEN

C...q + qbar -> gluino + ~chi0_1

          comfac=comfac*wids(pycomp(kfpr(isubsv,1)),2)*

     &    wids(pycomp(kfpr(isubsv,2)),2)

          fac0=comfac*as*aem*4d0/9d0/xw

          gm2=sqm3

          zm2=sqm4

          tanw=sqrt(xw/(1d0-xw))

          DO 1680 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1680

            ei=kchg(iabs(i),1)/3d0

            ia=iabs(i)

            xlqc = -tanw*ei*zmix(izid,1)

            xrqc =(sign(1d0,ei)*zmix(izid,2)-tanw*

     &      (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0

            xlq2=xlqc**2

            xrq2=xrqc**2

            xml2=pmas(pycomp(ksusy1+ia),1)**2

            xmr2=pmas(pycomp(ksusy2+ia),1)**2

            atkin=(th-gm2)*(th-zm2)/(th-xml2)**2

            aukin=(uh-gm2)*(uh-zm2)/(uh-xml2)**2

            atukin=smz(izid)*sqrt(gm2)*sh/(th-xml2)/(uh-xml2)

            sgchil=xlq2*(atkin+aukin-2d0*atukin)

            atkin=(th-gm2)*(th-zm2)/(th-xmr2)**2

            aukin=(uh-gm2)*(uh-zm2)/(uh-xmr2)**2

            atukin=smz(izid)*sqrt(gm2)*sh/(th-xmr2)/(uh-xmr2)

            sgchir=xrq2*(atkin+aukin-2d0*atukin)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=fac0*(sgchil+sgchir)

 1680     CONTINUE

        ENDIF


      ELSEIF(isub.LE.250) THEN

        IF(isub.EQ.241) THEN

C...q + qbar' -> ~chi+-_1 + gluino

          facwg=comfac*as*aem/xw*2d0/9d0

          gm2=sqm3

          zm2=sqm4

          fac01=2d0*umix(izid,1)*vmix(izid,1)

          fac0=umix(izid,1)**2

          fac1=vmix(izid,1)**2

          DO 1700 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.10.OR.kfac(1,i).EQ.0) goto 1700

            DO 1690 j=mmin2,mmax2

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.10.OR.kfac(2,j).EQ.0) goto 1690

              IF(i*j.GT.0.OR.mod(ia+ja,2).EQ.0) goto 1690

              fckm=1d0

              IF(ia.LE.10) fckm=vckm((ia+1)/2,(ja+1)/2)

              kchsum=kchg(ia,1)*isign(1,i)+kchg(ja,1)*isign(1,j)

              kchw=2

              IF(kchsum.LT.0) kchw=3

              xmu2=pmas(pycomp(ksusy1+2),1)**2

              xmd2=pmas(pycomp(ksusy1+1),1)**2

              atkin=(th-gm2)*(th-zm2)/(th-xmu2)**2

              aukin=(uh-gm2)*(uh-zm2)/(uh-xmd2)**2

              atukin=smw(izid)*sqrt(gm2)*sh/(th-xmu2)/(uh-xmd2)

              xmu2=pmas(pycomp(ksusy2+2),1)**2

              xmd2=pmas(pycomp(ksusy2+1),1)**2

              atkin=(atkin+(th-gm2)*(th-zm2)/(th-xmu2)**2)/2d0

              aukin=(aukin+(uh-gm2)*(uh-zm2)/(uh-xmd2)**2)/2d0

              atukin=(atukin+smw(izid)*sqrt(gm2)*

     &        sh/(th-xmu2)/(uh-xmd2))/2d0

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facwg*fckm*(fac0*atkin+fac1*aukin-

     &        fac01*atukin)*wids(pycomp(kfpr(isubsv,1)),2)*

     &        wids(pycomp(kfpr(isubsv,2)),kchw)

 1690       CONTINUE

 1700     CONTINUE


        ELSEIF(isub.EQ.243) THEN

C...q + qbar -> gluino + gluino

          comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)

          xmt=sqm3-th

          xmu=sqm3-uh

          DO 1710 i=mmina,mmaxa

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 1710

            nchn=nchn+1

            xsu=pmas(pycomp(ksusy1+iabs(i)),1)**2-uh

            xst=pmas(pycomp(ksusy1+iabs(i)),1)**2-th

            facgg1=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+

     &      2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+

     &      xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +

     &      sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )

            xsu=pmas(pycomp(ksusy2+iabs(i)),1)**2-uh

            xst=pmas(pycomp(ksusy2+iabs(i)),1)**2-th

            facgg2=comfac*as**2*8d0/3d0*( (xmt**2+xmu**2+

     &      2d0*sqm3*sh)/sh2 +4d0/9d0*(xmt**2/xst**2+

     &      xmu**2/xsu**2) - (xmt**2+sh*sqm3)/sh/xst +

     &      sqm3*sh/xst/xsu/9d0- (xmu**2+sh*sqm3)/sh/xsu )

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

C...1/2 for identical particles

            sigh(nchn)=0.25d0*(facgg1+facgg2)

 1710     CONTINUE


        ELSEIF(isub.EQ.244) THEN

C...g + g -> gluino + gluino

          comfac=comfac*wids(pycomp(kfpr(isubsv,1)),1)

          xmt=sqm3-th

          xmu=sqm3-uh

          facqq1=comfac*as**2*9d0/4d0*(

     &    (xmt*xmu-2d0*sqm3*(th+sqm3))/xmt**2 -

     &    (xmt*xmu+sqm3*(uh-th))/sh/xmt )

          facqq2=comfac*as**2*9d0/4d0*(

     &    (xmu*xmt-2d0*sqm3*(uh+sqm3))/xmu**2 -

     &    (xmu*xmt+sqm3*(th-uh))/sh/xmu )

          facqq3=comfac*as**2*9d0/4d0*(2d0*xmt*xmu/sh2 +

     &    sqm3*(sh-4d0*sqm3)/xmt/xmu)

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1720

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqq1/2d0

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=facqq2/2d0

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=3

          sigh(nchn)=facqq3/2d0

 1720     CONTINUE


        ELSEIF(isub.EQ.246) THEN

C...g + q_j -> ~chi0_1 + ~q_j

          fac0=comfac*as*aem/6d0/xw

          zm2=sqm4

          qm2=sqm3

          tanw=sqrt(xw/(1d0-xw))

          faczq0=fac0*( (zm2-th)/sh +

     &    (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -

     &    (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )

          kfnsq=mod(kfpr(isubsv,1),ksusy1)

          DO 1740 i=-kfnsq,kfnsq,2*kfnsq

            IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1740

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1740

            ei=kchg(iabs(i),1)/3d0

            ia=iabs(i)

            xrqz = -tanw*ei*zmix(izid,1)

            xlqz =(sign(1d0,ei)*zmix(izid,2)-tanw*

     &      (sign(1d0,ei)-2d0*ei)*zmix(izid,1))/2d0

            IF(ilr.EQ.0) THEN

              bs=xlqz**2*sfmix(ia,1)**2+xrqz**2*sfmix(ia,2)**2

            ELSE

              bs=xlqz**2*sfmix(ia,3)**2+xrqz**2*sfmix(ia,4)**2

            ENDIF

            faczq=faczq0*bs

            kchq=2

            IF(i.LT.0) kchq=3

            DO 1730 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1730

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1730

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*

     &        wids(pycomp(kfpr(isubsv,2)),2)

 1730       CONTINUE

 1740     CONTINUE

        ENDIF


      ELSEIF(isub.LE.260) THEN

        IF(isub.EQ.254) THEN

C...g + q_j -> ~chi1_1 + ~q_i

          fac0=comfac*as*aem/12d0/xw

          zm2=sqm4

          qm2=sqm3

          au=umix(izid,1)**2

          ad=vmix(izid,1)**2

          faczq0=fac0*( (zm2-th)/sh +

     &    (uh-zm2)*(uh+qm2)/(uh-qm2)**2 -

     &    (sh*(uh+zm2)+2d0*(qm2-zm2)*(zm2-uh))/sh/(uh-qm2) )

          kfnsq1=mod(kfpr(isubsv,1),ksusy1)

          IF(mod(kfnsq1,2).EQ.0) THEN

            kfnsq=kfnsq1-1

            kchw=2

          ELSE

            kfnsq=kfnsq1+1

            kchw=3

          ENDIF

          DO 1760 i=-kfnsq,kfnsq,2*kfnsq

            IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1760

            IF(i.EQ.0.OR.iabs(i).GT.mstp(58)) goto 1760

            ia=iabs(i)

            IF(mod(ia,2).EQ.0) THEN

              faczq=faczq0*au

            ELSE

              faczq=faczq0*ad

            ENDIF

            faczq=faczq*sfmix(kfnsq1,1+2*ilr)**2

            kchq=2

            IF(i.LT.0) kchq=3

            kchwq=kchw

            IF(i.LT.0) kchwq=5-kchw

            DO 1750 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1750

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1750

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=faczq*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*

     &        wids(pycomp(kfpr(isubsv,2)),kchwq)

 1750       CONTINUE

 1760     CONTINUE


        ELSEIF(isub.EQ.258) THEN

C...g + q_j -> gluino + ~q_i

          xg2=sqm4

          xq2=sqm3

          xmt=xg2-th

          xmu=xg2-uh

          xst=xq2-th

          xsu=xq2-uh

          facqg1=0.5d0*4d0/9d0*xmt/sh + (xmt*sh+2d0*xg2*xst)/xmt**2 -

     &    ( (sh-xq2+xg2)*(-xst)-sh*xg2 )/sh/(-xmt) +

     &    0.5d0*1d0/2d0*( xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst) +

     &    (-xmu)*(th+xg2+2d0*xq2) )/2d0/xmt/xsu

          facqg2= 4d0/9d0*(-xmu)*(uh+xq2)/xsu**2 + 1d0/18d0*

     &    (sh*(uh+xg2)

     &    +2d0*(xq2-xg2)*xmu)/sh/(-xsu) + 0.5d0*4d0/9d0*xmt/sh +

     &    0.5d0*1d0/2d0*(xst*(th+2d0*uh+xg2)-xmt*(sh-2d0*xst)+

     &    (-xmu)*(th+xg2+2d0*xq2))/2d0/xmt/xsu

          facqg1=comfac*as**2*facqg1/2d0

          facqg2=comfac*as**2*facqg2/2d0

          kfnsq=mod(kfpr(isubsv,1),ksusy1)

          DO 1780 i=-kfnsq,kfnsq,2*kfnsq

            IF(i.LT.mmina.OR.i.GT.mmaxa) goto 1780

            IF(i.EQ.0.OR.iabs(i).GT.10) goto 1780

            kchq=2

            IF(i.LT.0) kchq=3

            facsel=rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*

     &      wids(pycomp(kfpr(isubsv,2)),2)

            DO 1770 isde=1,2

              IF(isde.EQ.1.AND.kfac(1,i)*kfac(2,21).EQ.0) goto 1770

              IF(isde.EQ.2.AND.kfac(1,21)*kfac(2,i).EQ.0) goto 1770

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=1

              sigh(nchn)=facqg1*facsel

              nchn=nchn+1

              isig(nchn,isde)=i

              isig(nchn,3-isde)=21

              isig(nchn,3)=2

              sigh(nchn)=facqg2*facsel

 1770       CONTINUE

 1780     CONTINUE

        ENDIF


      ELSEIF(isub.LE.270) THEN

        IF(isub.EQ.261) THEN

C...q_i + q_ibar -> ~t_1 + ~t_1bar

          facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )*

     &    wids(pycomp(kfpr(isubsv,1)),1)

          kfnsq=mod(kfpr(isubsv,1),ksusy1)

          fac0=as**2*4d0/9d0

          DO 1790 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1790

            IF(ia.GE.11.AND.ia.LE.18) THEN

              ei=kchg(ia,1)/3d0

              ej=kchg(kfnsq,1)/3d0

              t3i=sign(1d0,ei)/2d0

              t3j=sign(1d0,ej)/2d0

              xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,2*ilr+1)**2

              xrq=2d0*(-ej*xw)*sfmix(kfnsq,2*ilr+2)**2

              xlf=2d0*(t3i-ei*xw)

              xrf=2d0*(-ei*xw)

              taa=0.5d0*(ei*ej)**2

              tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2

              tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)

              taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)

              taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)

              fac0=aem**2*12d0*(taa+tzz+taz)

            ENDIF

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq1*fac0

 1790     CONTINUE


        ELSEIF(isub.EQ.263) THEN

C...f + fbar -> ~t1 + ~t2bar

          DO 1800 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.kfac(1,i)*kfac(2,-i).EQ.0) goto 1800

            ei=kchg(iabs(i),1)/3d0

            tt3i=sign(1d0,ei)/2d0

            ej=2d0/3d0

            tt3j=1d0/2d0

            fcol=1d0

C...Color factor for e+ e-

            IF(ia.GE.11) fcol=3d0

            xlq=2d0*(tt3j-ej*xw)

            xrq=2d0*(-ej*xw)

            xlf=2d0*(tt3i-ei*xw)

            xrf=2d0*(-ei*xw)

            tzz=(xlf**2+xrf**2)*(xlq-xrq)**2/64d0/xw**2/(1d0-xw)**2

            tzz=tzz*(sfmix(6,1)*sfmix(6,2))**2

            tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)

C...Factor of 2 for t1 t2bar + t2 t1bar

            facqq1=2d0*comfac*aem**2*tzz*fcol*4d0

            facqq1=facqq1*( uh*th-sqm3*sqm4 )/sh2

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),2)*

     &      wids(pycomp(kfpr(isubsv,2)),3)

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=2

            sigh(nchn)=facqq1*wids(pycomp(kfpr(isubsv,1)),3)*

     &      wids(pycomp(kfpr(isubsv,2)),2)

 1800     CONTINUE


        ELSEIF(isub.EQ.264) THEN

C...g + g -> ~t_1 + ~t_1bar

          xsu=sqm3-uh

          xst=sqm3-th

          fac0=comfac*as**2*(7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )*0.5d0*

     &    wids(pycomp(kfpr(isubsv,1)),1)

          facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)

          facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1810

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqq1

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=facqq2

 1810     CONTINUE

        ENDIF


      ELSEIF(isub.LE.280) THEN

        IF(isub.EQ.271) THEN

C...q + q' -> ~q + ~q' (~g exchange)

          xmg2=pmas(pycomp(ksusy1+21),1)**2

          xmt=xmg2-th

          xmu=xmg2-uh

          xsu1=sqm3-uh

          xsu2=sqm4-uh

          xst1=sqm3-th

          xst2=sqm4-th

          IF(ilr.EQ.1) THEN

            facqq1=comfac*as**2*4d0/9d0*( -(xst1*xst2+sh*th)/xmt**2 )

            facqq2=comfac*as**2*4d0/9d0*( -(xsu1*xsu2+sh*uh)/xmu**2 )

            facqqb=0.0d0

          ELSE

            facqq1=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmt**2 )

            facqq2=0.5d0*comfac*as**2*4d0/9d0*( sh*xmg2/xmu**2 )

            facqqb=0.5d0*comfac*as**2*4d0/9d0*( -2d0*sh*xmg2/3d0/

     &      xmt/xmu )

          ENDIF

          kfnsqi=mod(kfpr(isubsv,1),ksusy1)

          kfnsqj=mod(kfpr(isubsv,2),ksusy1)

          DO 1830 i=-kfnsqi,kfnsqi,2*kfnsqi

            IF(i.LT.mmin1.OR.i.GT.mmax1) goto 1830

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 1830

            kchq=2

            IF(i.LT.0) kchq=3

            DO 1820 j=-kfnsqj,kfnsqj,2*kfnsqj

              IF(j.LT.mmin2.OR.j.GT.mmax2) goto 1820

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 1820

              IF(i*j.LT.0) goto 1820

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*

     &        wids(pycomp(kfpr(isubsv,2)),kchq)

              IF(i.EQ.j) THEN

                IF(isubsv.LE.272) THEN

                  sigh(nchn)=(facqq1+0.5d0*facqqb)*rkf*

     &            wids(pycomp(kfpr(isubsv,1)),kchq+2)

                ELSE

                  sigh(nchn)=(facqq1+0.5d0*facqqb)*rkf*

     &            wids(pycomp(kfpr(isubsv,1)),kchq)*

     &            wids(pycomp(kfpr(isubsv,2)),kchq)

                ENDIF

                nchn=nchn+1

                isig(nchn,1)=i

                isig(nchn,2)=j

                isig(nchn,3)=2

                IF(isubsv.LE.272) THEN

                  sigh(nchn)=(facqq2+0.5d0*facqqb)*rkf*

     &            wids(pycomp(kfpr(isubsv,1)),kchq+2)

                ELSE

                  sigh(nchn)=(facqq2+0.5d0*facqqb)*rkf*

     &            wids(pycomp(kfpr(isubsv,1)),kchq)*

     &            wids(pycomp(kfpr(isubsv,2)),kchq)

                ENDIF

              ENDIF

 1820       CONTINUE

 1830     CONTINUE


        ELSEIF(isub.EQ.274) THEN

C...q + qbar -> ~q' + ~qbar'

          xmg2=pmas(pycomp(ksusy1+21),1)**2

          xmt=xmg2-th

          xmu=xmg2-uh

          IF(ilr.EQ.0) THEN

            facqq1=comfac*as**2*4d0/9d0*(

     &      (uh*th-sqm3*sqm4)/xmt**2 )

            facqqb=comfac*as**2*4d0/9d0*(

     &      (uh*th-sqm3*sqm4)/sh2*(2d0-2d0/3d0*sh/xmt**2))

            facqqb=facqqb+facqq1

          ELSE

            facqq1=comfac*as**2*4d0/9d0*( xmg2*sh/xmt**2 )

            facqqb=facqq1

          ENDIF

          kfnsqi=mod(kfpr(isubsv,1),ksusy1)

          kfnsqj=mod(kfpr(isubsv,2),ksusy1)

          DO 1850 i=-kfnsqi,kfnsqi,2*kfnsqi

            IF(i.LT.mmin1.OR.i.GT.mmax1) goto 1850

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.mstp(58).OR.kfac(1,i).EQ.0) goto 1850

            kchq=2

            IF(i.LT.0) kchq=3

            DO 1840 j=-kfnsqj,kfnsqj,2*kfnsqj

              IF(j.LT.mmin2.OR.j.GT.mmax2) goto 1840

              ja=iabs(j)

              IF(j.EQ.0.OR.ja.GT.mstp(58).OR.kfac(2,j).EQ.0) goto 1840

              IF(i*j.GT.0) goto 1840

              nchn=nchn+1

              isig(nchn,1)=i

              isig(nchn,2)=j

              isig(nchn,3)=1

              sigh(nchn)=facqq1*rkf*wids(pycomp(kfpr(isubsv,1)),kchq)*

     &        wids(pycomp(kfpr(isubsv,2)),5-kchq)

              IF(i.EQ.-j) sigh(nchn)=facqqb*rkf*

     &        wids(pycomp(kfpr(isubsv,1)),1)

 1840       CONTINUE

 1850     CONTINUE


        ELSEIF(isub.EQ.277) THEN

C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j

C...if i .eq. j covered in 274

          facqq1=comfac*( (uh*th-sqm3*sqm4)/ sh**2 )

          kfnsq=mod(kfpr(isubsv,1),ksusy1)

          fac0=0d0

          DO 1860 i=mmin1,mmax1

            ia=iabs(i)

            IF(i.EQ.0.OR.ia.GT.mstp(58).OR.

     &      kfac(1,i)*kfac(2,-i).EQ.0) goto 1860

            IF(ia.EQ.kfnsq) goto 1860

            IF(ia.EQ.11.OR.ia.EQ.13.OR.ia.EQ.15) THEN

              ei=kchg(ia,1)/3d0

              ej=kchg(kfnsq,1)/3d0

              t3j=sign(0.5d0,ej)

              t3i=sign(1d0,ei)/2d0

              IF(ilr.EQ.0) THEN

                xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,1)

                xrq=2d0*(-ej*xw)*sfmix(kfnsq,2)

              ELSE

                xlq=2d0*(t3j-ej*xw)*sfmix(kfnsq,3)

                xrq=2d0*(-ej*xw)*sfmix(kfnsq,4)

              ENDIF

              xlf=2d0*(t3i-ei*xw)

              xrf=2d0*(-ei*xw)

              IF(ilr.EQ.0) THEN

                xrq=0d0

              ELSE

                xlq=0d0

              ENDIF

              taa=0.5d0*(ei*ej)**2

              tzz=(xlf**2+xrf**2)*(xlq+xrq)**2/64d0/xw**2/(1d0-xw)**2

              tzz=tzz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)

              taz=ei*ej*(xlq+xrq)*(xlf+xrf)/8d0/xw/(1d0-xw)

              taz=taz/((1d0-sqmz/sh)**2+sqmz*(zwid/sh)**2)*(1d0-sqmz/sh)

              fac0=aem**2*12d0*(taa+tzz+taz)

            ELSEIF(ia.LE.6) THEN

              fac0=as**2*8d0/9d0/2d0

            ENDIF

            nchn=nchn+1

            isig(nchn,1)=i

            isig(nchn,2)=-i

            isig(nchn,3)=1

            sigh(nchn)=facqq1*fac0*rkf*wids(pycomp(kfpr(isubsv,1)),1)

 1860     CONTINUE


        ELSEIF(isub.EQ.279) THEN

C...g + g -> ~q_j + ~q_jbar

          xsu=sqm3-uh

          xst=sqm3-th

C...5=RKF because ~t ~tbar treated separately

          fac0=rkf*comfac*as**2*( 7d0/48d0+3d0*(uh-th)**2/16d0/sh2 )

          facqq1=fac0*(0.5d0+2d0*sqm3*th/xst**2 + 2d0*sqm3**2/xsu/xst)

          facqq2=fac0*(0.5d0+2d0*sqm3*uh/xsu**2 + 2d0*sqm3**2/xsu/xst)

          IF(kfac(1,21)*kfac(2,21).EQ.0) goto 1870

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=1

          sigh(nchn)=facqq1/2d0*wids(pycomp(kfpr(isubsv,1)),1)

          nchn=nchn+1

          isig(nchn,1)=21

          isig(nchn,2)=21

          isig(nchn,3)=2

          sigh(nchn)=facqq2/2d0*wids(pycomp(kfpr(isubsv,1)),1)

 1870     CONTINUE


        ENDIF

CMRENNA--

      ENDIF


C...Multiply with parton distributions

      IF(isub.LE.90.OR.isub.GE.96) THEN

        DO 1880 ichn=1,nchn

          IF(mint(45).GE.2) THEN

            kfl1=isig(ichn,1)

            sigh(ichn)=sigh(ichn)*xsfx(1,kfl1)

          ENDIF

          IF(mint(46).GE.2) THEN

            kfl2=isig(ichn,2)

            sigh(ichn)=sigh(ichn)*xsfx(2,kfl2)

          ENDIF

          sigs=sigs+sigh(ichn)

 1880   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYPDFU

C...Gives electron, photon, pi+, neutron, proton and hyperon

C...parton distributions according to a few different parametrizations.

C...Note that what is coded is x times the probability distribution,

C...i.e. xq(x,Q2) etc.


      SUBROUTINE pypdfu(KF,X,Q2,XPQ)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),

     &xpdir(-6:6)

      SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint8/

C...Local arrays.

      dimension xpq(-25:25),xpel(-25:25),xpga(-6:6),vxpga(-6:6),

     &xppi(-6:6),xppr(-6:6)


C...Interface to PDFLIB.

      common/w50513/xmin,xmax,q2min,q2max

      SAVE /w50513/

      DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,

     &value(20),xmin,xmax,q2min,q2max

      CHARACTER*20 parm(20)

      DATA value/20*0d0/,parm/20*' '/


C...Data related to Schuler-Sjostrand photon distributions.

      DATA alamga/0.2d0/, pmcga/1.3d0/, pmbga/4.6d0/


C...Reset parton distributions.

      mint(92)=0

      DO 100 kfl=-25,25

        xpq(kfl)=0d0

  100 CONTINUE


C...Check x and particle species.

      IF(x.LE.0d0.OR.x.GE.1d0) THEN

        WRITE(mstu(11),5000) x

        RETURN

      ENDIF

      kfa=iabs(kf)

      IF(kfa.NE.11.AND.kfa.NE.22.AND.kfa.NE.211.AND.kfa.NE.2112.AND.

     &kfa.NE.2212.AND.kfa.NE.3122.AND.kfa.NE.3112.AND.kfa.NE.3212

     &.AND.kfa.NE.3222.AND.kfa.NE.3312.AND.kfa.NE.3322.AND.

     &kfa.NE.3334.AND.kfa.NE.111) THEN

        WRITE(mstu(11),5100) kf

        RETURN

      ENDIF


C...Electron parton distribution call.

      IF(kfa.EQ.11) THEN

        CALL pypdel(x,q2,xpel)

        DO 110 kfl=-25,25

          xpq(kfl)=xpel(kfl)

  110   CONTINUE


C...Photon parton distribution call (VDM+anomalous).

      ELSEIF(kfa.EQ.22.AND.mint(109).LE.1) THEN

        IF(mstp(56).EQ.1.AND.mstp(55).EQ.1) THEN

          CALL pypdga(x,q2,xpga)

          DO 120 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  120     CONTINUE

        ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.5.AND.mstp(55).LE.8) THEN

          q2mx=q2

          p2mx=0.36d0

          IF(mstp(55).GE.7) p2mx=4.0d0

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pyggam(mstp(55)-4,x,q2mx,0d0,mstp(60),f2gam,xpga)

          DO 130 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  130     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(56).EQ.1.AND.mstp(55).GE.9.AND.mstp(55).LE.12) THEN

          q2mx=q2

          p2mx=0.36d0

          IF(mstp(55).GE.11) p2mx=4.0d0

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pyggam(mstp(55)-8,x,q2mx,0d0,mstp(60),f2gam,xpga)

          DO 140 kfl=-6,6

            xpq(kfl)=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)

  140     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(56).EQ.2) THEN

C...Call PDFLIB parton distributions.

          parm(1)='NPTYPE'

          value(1)=3

          parm(2)='NGROUP'

          value(2)=mstp(55)/1000

          parm(3)='NSET'

          value(3)=mod(mstp(55),1000)

          IF(mint(93).NE.3000000+mstp(55)) THEN

            CALL pdfset(parm,value)

            mint(93)=3000000+mstp(55)

          ENDIF

          xx=x

          qq=sqrt(max(0d0,q2min,q2))

          IF(mstp(57).EQ.0) qq=sqrt(q2min)

          CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)

          vint(231)=q2min

          xpq(0)=glu

          xpq(1)=dnv

          xpq(-1)=dnv

          xpq(2)=upv

          xpq(-2)=upv

          xpq(3)=str

          xpq(-3)=str

          xpq(4)=chm

          xpq(-4)=chm

          xpq(5)=bot

          xpq(-5)=bot

          xpq(6)=top

          xpq(-6)=top

        ELSE

          WRITE(mstu(11),5200) kf,mstp(56),mstp(55)

        ENDIF


C...Pion/gammaVDM parton distribution call.

      ELSEIF(kfa.EQ.211.OR.kfa.EQ.111.OR.(kfa.EQ.22.AND.

     &  mint(109).EQ.2)) THEN

        IF(kfa.EQ.22.AND.mstp(56).EQ.1.AND.mstp(55).GE.5.AND.

     &  mstp(55).LE.12) THEN

          iset=1+mod(mstp(55)-1,4)

          q2mx=q2

          p2mx=0.36d0

          IF(iset.GE.3) p2mx=4.0d0

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pygvmd(iset,2,x,q2mx,p2mx,alamga,xpga,vxpga)

          DO 150 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  150     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(54).EQ.1.AND.mstp(53).GE.1.AND.mstp(53).LE.3) THEN

          CALL pypdpi(x,q2,xppi)

          DO 160 kfl=-6,6

            xpq(kfl)=xppi(kfl)

  160     CONTINUE

        ELSEIF(mstp(54).EQ.2) THEN

C...Call PDFLIB parton distributions.

          parm(1)='NPTYPE'

          value(1)=2

          parm(2)='NGROUP'

          value(2)=mstp(53)/1000

          parm(3)='NSET'

          value(3)=mod(mstp(53),1000)

          IF(mint(93).NE.2000000+mstp(53)) THEN

            CALL pdfset(parm,value)

            mint(93)=2000000+mstp(53)

          ENDIF

          xx=x

          qq=sqrt(max(0d0,q2min,q2))

          IF(mstp(57).EQ.0) qq=sqrt(q2min)

          CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)

          vint(231)=q2min

          xpq(0)=glu

          xpq(1)=dsea

          xpq(-1)=upv+dsea

          xpq(2)=upv+usea

          xpq(-2)=usea

          xpq(3)=str

          xpq(-3)=str

          xpq(4)=chm

          xpq(-4)=chm

          xpq(5)=bot

          xpq(-5)=bot

          xpq(6)=top

          xpq(-6)=top

        ELSE

          WRITE(mstu(11),5200) kf,mstp(54),mstp(53)

        ENDIF


C...Anomalous photon parton distribution call.

      ELSEIF(kfa.EQ.22.AND.mint(109).EQ.3) THEN

        q2mx=q2

        p2mx=parp(15)**2

        IF(mstp(56).EQ.1.AND.mstp(55).LE.8) THEN

          IF(mstp(55).EQ.5.OR.mstp(55).EQ.6) p2mx=0.36d0

          IF(mstp(55).EQ.7.OR.mstp(55).EQ.8) p2mx=4.0d0

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)

          DO 170 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  170     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(56).EQ.1) THEN

          IF(mstp(55).EQ.9.OR.mstp(55).EQ.10) p2mx=0.36d0

          IF(mstp(55).EQ.11.OR.mstp(55).EQ.12) p2mx=4.0d0

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pyggam(mstp(55)-8,x,q2mx,0d0,mstp(60),f2gm,xpga)

          DO 180 kfl=-6,6

            xpq(kfl)=max(0d0,xpanl(kfl)+xpbeh(kfl)+xpdir(kfl))

  180     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(56).EQ.2) THEN

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pygano(0,x,q2mx,p2mx,alamga,xpga,vxpga)

          DO 190 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  190     CONTINUE

          vint(231)=p2mx

        ELSEIF(mstp(55).GE.1.AND.mstp(55).LE.5) THEN

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pygvmd(0,mstp(55),x,q2mx,p2mx,parp(1),xpga,vxpga)

          DO 200 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  200     CONTINUE

          vint(231)=p2mx

        ELSE

  210     rkf=11d0*pyr(0)

          kfr=1

          IF(rkf.GT.1d0) kfr=2

          IF(rkf.GT.5d0) kfr=3

          IF(rkf.GT.6d0) kfr=4

          IF(rkf.GT.10d0) kfr=5

          IF(kfr.EQ.4.AND.q2.LT.pmcga**2) goto 210

          IF(kfr.EQ.5.AND.q2.LT.pmbga**2) goto 210

          IF(mstp(57).EQ.0) q2mx=p2mx

          CALL pygvmd(0,kfr,x,q2mx,p2mx,parp(1),xpga,vxpga)

          DO 220 kfl=-6,6

            xpq(kfl)=xpga(kfl)

  220     CONTINUE

          vint(231)=p2mx

        ENDIF


C...Proton parton distribution call.

      ELSE

        IF(mstp(52).EQ.1.AND.mstp(51).GE.1.AND.mstp(51).LE.11) THEN

          CALL pypdpr(x,q2,xppr)

          DO 230 kfl=-6,6

            xpq(kfl)=xppr(kfl)

  230     CONTINUE

        ELSEIF(mstp(52).EQ.2) THEN

C...Call PDFLIB parton distributions.

          parm(1)='NPTYPE'

          value(1)=1

          parm(2)='NGROUP'

          value(2)=mstp(51)/1000

          parm(3)='NSET'

          value(3)=mod(mstp(51),1000)

          IF(mint(93).NE.1000000+mstp(51)) THEN

            CALL pdfset(parm,value)

            mint(93)=1000000+mstp(51)

          ENDIF

          xx=x

          qq=sqrt(max(0d0,q2min,q2))

          IF(mstp(57).EQ.0) qq=sqrt(q2min)

          CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)

          vint(231)=q2min

          xpq(0)=glu

          xpq(1)=dnv+dsea

          xpq(-1)=dsea

          xpq(2)=upv+usea

          xpq(-2)=usea

          xpq(3)=str

          xpq(-3)=str

          xpq(4)=chm

          xpq(-4)=chm

          xpq(5)=bot

          xpq(-5)=bot

          xpq(6)=top

          xpq(-6)=top

        ELSE

          WRITE(mstu(11),5200) kf,mstp(52),mstp(51)

        ENDIF

      ENDIF


C...Isospin average for pi0/gammaVDM.

      IF(kfa.EQ.111.OR.(kfa.EQ.22.AND.mint(109).EQ.2)) THEN

        IF(kfa.EQ.22.AND.mstp(55).GE.5.AND.mstp(55).LE.12) THEN

          xpv=xpq(2)-xpq(1)

          xpq(2)=xpq(1)

          xpq(-2)=xpq(-1)

        ELSE

          xps=0.5d0*(xpq(1)+xpq(-2))

          xpv=0.5d0*(xpq(2)+xpq(-1))-xps

          xpq(2)=xps

          xpq(-1)=xps

        ENDIF

        IF(kfa.EQ.22.AND.mint(105).LE.223) THEN

          xpq(1)=xpq(1)+0.2d0*xpv

          xpq(-1)=xpq(-1)+0.2d0*xpv

          xpq(2)=xpq(2)+0.8d0*xpv

          xpq(-2)=xpq(-2)+0.8d0*xpv

        ELSEIF(kfa.EQ.22.AND.mint(105).EQ.333) THEN

          xpq(3)=xpq(3)+xpv

          xpq(-3)=xpq(-3)+xpv

        ELSEIF(kfa.EQ.22.AND.mint(105).EQ.443) THEN

          xpq(4)=xpq(4)+xpv

          xpq(-4)=xpq(-4)+xpv

          IF(mstp(55).GE.9) THEN

            DO 240 kfl=-6,6

              xpq(kfl)=0d0

  240       CONTINUE

          ENDIF

        ELSE

          xpq(1)=xpq(1)+0.5d0*xpv

          xpq(-1)=xpq(-1)+0.5d0*xpv

          xpq(2)=xpq(2)+0.5d0*xpv

          xpq(-2)=xpq(-2)+0.5d0*xpv

        ENDIF


C...Rescale for gammaVDM by effective gamma -> rho coupling.

        IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN

          DO 250 kfl=-6,6

            xpq(kfl)=vint(281)*xpq(kfl)

  250     CONTINUE

          vint(232)=vint(281)*xpv

        ENDIF


C...Isospin conjugation for neutron.

      ELSEIF(kfa.EQ.2112) THEN

        xps=xpq(1)

        xpq(1)=xpq(2)

        xpq(2)=xps

        xps=xpq(-1)

        xpq(-1)=xpq(-2)

        xpq(-2)=xps


C...Simple recipes for hyperon (average valence parton distribution).

      ELSEIF(kfa.EQ.3122.OR.kfa.EQ.3112.OR.kfa.EQ.3212.OR.kfa.EQ.3222

     &  .OR.kfa.EQ.3312.OR.kfa.EQ.3322.OR.kfa.EQ.3334) THEN

        xpval=(xpq(1)+xpq(2)-xpq(-1)-xpq(-2))/3d0

        xpsea=0.5d0*(xpq(-1)+xpq(-2))

        xpq(1)=xpsea

        xpq(2)=xpsea

        xpq(-1)=xpsea

        xpq(-2)=xpsea

        xpq(kfa/1000)=xpq(kfa/1000)+xpval

        xpq(mod(kfa/100,10))=xpq(mod(kfa/100,10))+xpval

        xpq(mod(kfa/10,10))=xpq(mod(kfa/10,10))+xpval

      ENDIF


C...Charge conjugation for antiparticle.

      IF(kf.LT.0) THEN

        DO 260 kfl=1,25

          IF(kfl.EQ.21.OR.kfl.EQ.22.OR.kfl.EQ.23.OR.kfl.EQ.25) goto 260

          xps=xpq(kfl)

          xpq(kfl)=xpq(-kfl)

          xpq(-kfl)=xps

  260   CONTINUE

      ENDIF


C...Allow gluon also in position 21.

      xpq(21)=xpq(0)


C...Check positivity and reset above maximum allowed flavour.

      DO 270 kfl=-25,25

        xpq(kfl)=max(0d0,xpq(kfl))

        IF(iabs(kfl).GT.mstp(58).AND.iabs(kfl).LE.8) xpq(kfl)=0d0

  270 CONTINUE


C...Formats for error printouts.

 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)

 5100 FORMAT(' Error: illegal particle code for parton distribution;',

     &' KF =',i5)

 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',

     &3i5)


      RETURN

      END


C*********************************************************************


C...PYPDFL

C...Gives proton parton distribution at small x and/or Q^2 according to

C...correct limiting behaviour.


      SUBROUTINE pypdfl(KF,X,Q2,XPQ)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/

C...Local arrays.

      dimension xpq(-25:25),xpa(-25:25),xpb(-25:25),wtsb(-3:3)

      DATA rmr/0.92d0/,rmp/0.38d0/,wtsb/0.5d0,1d0,1d0,5d0,1d0,1d0,0.5d0/


C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.

      mint(92)=0

      kfa=iabs(kf)

      iacc=0

      IF((kfa.EQ.2212.OR.kfa.EQ.2112).AND.mstp(57).GE.2) iacc=1

      IF(kfa.EQ.211.AND.mstp(57).GE.3) iacc=1

      IF(kfa.EQ.22.AND.mint(109).EQ.2.AND.mstp(57).GE.3) iacc=1

      IF(iacc.EQ.0) THEN

        CALL pypdfu(kf,x,q2,xpq)

        RETURN

      ENDIF


C...Reset. Check x.

      DO 100 kfl=-25,25

        xpq(kfl)=0d0

  100 CONTINUE

      IF(x.LE.0d0.OR.x.GE.1d0) THEN

        WRITE(mstu(11),5000) x

        RETURN

      ENDIF


C...Define valence content.

      kfc=kf

      nv1=2

      nv2=1

      IF(kf.EQ.2212) THEN

        kfv1=2

        kfv2=1

      ELSEIF(kf.EQ.-2212) THEN

        kfv1=-2

        kfv2=-1

      ELSEIF(kf.EQ.2112) THEN

        kfv1=1

        kfv2=2

      ELSEIF(kf.EQ.-2112) THEN

        kfv1=-1

        kfv2=-2

      ELSEIF(kf.EQ.211) THEN

        nv1=1

        kfv1=2

        kfv2=-1

      ELSEIF(kf.EQ.-211) THEN

        nv1=1

        kfv1=-2

        kfv2=1

      ELSEIF(mint(105).LE.223) THEN

        kfv1=1

        wtv1=0.2d0

        kfv2=2

        wtv2=0.8d0

      ELSEIF(mint(105).EQ.333) THEN

        kfv1=3

        wtv1=1.0d0

        kfv2=1

        wtv2=0.0d0

      ELSEIF(mint(105).EQ.443) THEN

        kfv1=4

        wtv1=1.0d0

        kfv2=1

        wtv2=0.0d0

      ENDIF


C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.

      CALL pypdfu(kfc,x,q2,xpa)

      q2mn=max(3d0,vint(231))

      q2b=2d0+0.052d0**2*exp(3.56d0*sqrt(max(0d0,-log(3d0*x))))

      xmn=exp(-(log((q2mn-2d0)/0.052d0**2)/3.56d0)**2)/3d0


C...Large Q2 and large x: naive call is enough.

      IF(q2.GT.q2mn.AND.q2.GT.q2b) THEN

        DO 110 kfl=-25,25

          xpq(kfl)=xpa(kfl)

  110   CONTINUE

        mint(92)=1


C...Small Q2 and large x: dampen boundary value.

      ELSEIF(x.GT.xmn) THEN


C...Evaluate at boundary and define dampening factors.

        CALL pypdfu(kfc,x,q2mn,xpa)

        fv=(q2*(q2mn+rmr)/(q2mn*(q2+rmr)))**(0.55d0*(1d0-x)/(1d0-xmn))

        fs=(q2*(q2mn+rmp)/(q2mn*(q2+rmp)))**1.08d0


C...Separate valence and sea parts of parton distribution.

        IF(kfa.NE.22) THEN

          xfv1=xpa(kfv1)-xpa(-kfv1)

          xpa(kfv1)=xpa(-kfv1)

          xfv2=xpa(kfv2)-xpa(-kfv2)

          xpa(kfv2)=xpa(-kfv2)

        ELSE

          xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)

          xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)

          xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)

          xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)

        ENDIF


C...Dampen valence and sea separately. Put back together.

        DO 120 kfl=-25,25

          xpq(kfl)=fs*xpa(kfl)

  120   CONTINUE

        IF(kfa.NE.22) THEN

          xpq(kfv1)=xpq(kfv1)+fv*xfv1

          xpq(kfv2)=xpq(kfv2)+fv*xfv2

        ELSE

          xpq(kfv1)=xpq(kfv1)+fv*wtv1*vint(232)

          xpq(-kfv1)=xpq(-kfv1)+fv*wtv1*vint(232)

          xpq(kfv2)=xpq(kfv2)+fv*wtv2*vint(232)

          xpq(-kfv2)=xpq(-kfv2)+fv*wtv2*vint(232)

        ENDIF

        mint(92)=2


C...Large Q2 and small x: interpolate behaviour.

      ELSEIF(q2.GT.q2mn) THEN


C...Evaluate at extremes and define coefficients for interpolation.

        CALL pypdfu(kfc,xmn,q2mn,xpa)

        vi232a=vint(232)

        CALL pypdfu(kfc,x,q2b,xpb)

        vi232b=vint(232)

        fla=log(q2b/q2)/log(q2b/q2mn)

        fva=(x/xmn)**0.45d0*fla

        fsa=(x/xmn)**(-0.08d0)*fla

        fb=1d0-fla


C...Separate valence and sea parts of parton distribution.

        IF(kfa.NE.22) THEN

          xfva1=xpa(kfv1)-xpa(-kfv1)

          xpa(kfv1)=xpa(-kfv1)

          xfva2=xpa(kfv2)-xpa(-kfv2)

          xpa(kfv2)=xpa(-kfv2)

          xfvb1=xpb(kfv1)-xpb(-kfv1)

          xpb(kfv1)=xpb(-kfv1)

          xfvb2=xpb(kfv2)-xpb(-kfv2)

          xpb(kfv2)=xpb(-kfv2)

        ELSE

          xpa(kfv1)=xpa(kfv1)-wtv1*vi232a

          xpa(-kfv1)=xpa(-kfv1)-wtv1*vi232a

          xpa(kfv2)=xpa(kfv2)-wtv2*vi232a

          xpa(-kfv2)=xpa(-kfv2)-wtv2*vi232a

          xpb(kfv1)=xpb(kfv1)-wtv1*vi232b

          xpb(-kfv1)=xpb(-kfv1)-wtv1*vi232b

          xpb(kfv2)=xpb(kfv2)-wtv2*vi232b

          xpb(-kfv2)=xpb(-kfv2)-wtv2*vi232b

        ENDIF


C...Interpolate for valence and sea. Put back together.

        DO 130 kfl=-25,25

          xpq(kfl)=fsa*xpa(kfl)+fb*xpb(kfl)

  130   CONTINUE

        IF(kfa.NE.22) THEN

          xpq(kfv1)=xpq(kfv1)+(fva*xfva1+fb*xfvb1)

          xpq(kfv2)=xpq(kfv2)+(fva*xfva2+fb*xfvb2)

        ELSE

          xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vi232a+fb*vi232b)

          xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vi232a+fb*vi232b)

          xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vi232a+fb*vi232b)

          xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vi232a+fb*vi232b)

        ENDIF

        mint(92)=3


C...Small Q2 and small x: dampen boundary value and add term.

      ELSE


C...Evaluate at boundary and define dampening factors.

        CALL pypdfu(kfc,xmn,q2mn,xpa)

        fb=(xmn-x)*(q2mn-q2)/(xmn*q2mn)

        fa=1d0-fb

        fvc=(x/xmn)**0.45d0*(q2/(q2+rmr))**0.55d0

        fva=fvc*fa*((q2mn+rmr)/q2mn)**0.55d0

        fvb=fvc*fb*1.10d0*xmn**0.45d0*0.11d0

        fsc=(x/xmn)**(-0.08d0)*(q2/(q2+rmp))**1.08d0

        fsa=fsc*fa*((q2mn+rmp)/q2mn)**1.08d0

        fsb=fsc*fb*0.21d0*xmn**(-0.08d0)*0.21d0


C...Separate valence and sea parts of parton distribution.

        IF(kfa.NE.22) THEN

          xfv1=xpa(kfv1)-xpa(-kfv1)

          xpa(kfv1)=xpa(-kfv1)

          xfv2=xpa(kfv2)-xpa(-kfv2)

          xpa(kfv2)=xpa(-kfv2)

        ELSE

          xpa(kfv1)=xpa(kfv1)-wtv1*vint(232)

          xpa(-kfv1)=xpa(-kfv1)-wtv1*vint(232)

          xpa(kfv2)=xpa(kfv2)-wtv2*vint(232)

          xpa(-kfv2)=xpa(-kfv2)-wtv2*vint(232)

        ENDIF


C...Dampen valence and sea separately. Add constant terms.

C...Put back together.

        DO 140 kfl=-25,25

          xpq(kfl)=fsa*xpa(kfl)

  140   CONTINUE

        IF(kfa.NE.22) THEN

          DO 150 kfl=-3,3

            xpq(kfl)=xpq(kfl)+fsb*wtsb(kfl)

  150     CONTINUE

          xpq(kfv1)=xpq(kfv1)+(fva*xfv1+fvb*nv1)

          xpq(kfv2)=xpq(kfv2)+(fva*xfv2+fvb*nv2)

        ELSE

          DO 160 kfl=-3,3

            xpq(kfl)=xpq(kfl)+vint(281)*fsb*wtsb(kfl)

  160     CONTINUE

          xpq(kfv1)=xpq(kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))

          xpq(-kfv1)=xpq(-kfv1)+wtv1*(fva*vint(232)+fvb*vint(281))

          xpq(kfv2)=xpq(kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))

          xpq(-kfv2)=xpq(-kfv2)+wtv2*(fva*vint(232)+fvb*vint(281))

        ENDIF

        xpq(21)=xpq(0)

        mint(92)=4

      ENDIF


C...Format for error printout.

 5000 FORMAT(' Error: x value outside physical range; x =',1p,d12.3)


      RETURN

      END


C*********************************************************************


C...PYPDEL

C...Gives electron parton distribution.


      SUBROUTINE pypdel(X,Q2,XPEL)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/

C...Local arrays.

      dimension xpel(-25:25),xpga(-6:6),sxp(0:6)


C...Interface to PDFLIB.

      common/w50513/xmin,xmax,q2min,q2max

      SAVE /w50513/

      DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu,

     &value(20),xmin,xmax,q2min,q2max

      CHARACTER*20 parm(20)

      DATA value/20*0d0/,parm/20*' '/


C...Some common constants.

      DO 100 kfl=-25,25

        xpel(kfl)=0d0

  100 CONTINUE

      aem=paru(101)

      pme=pmas(11,1)

      xl=log(max(1d-10,x))

      x1l=log(max(1d-10,1d0-x))

      hle=log(max(3d0,q2/pme**2))

      hbe2=(aem/paru(1))*(hle-1d0)


C...Electron inside electron, see R. Kleiss et al., in Z physics at

C...LEP 1, CERN 89-08, p. 34

      IF(mstp(59).LE.1) THEN

        hde=1d0+(aem/paru(1))*(1.5d0*hle+1.289868d0)+(aem/paru(1))**2*

     &  (-2.164868d0*hle**2+9.840808d0*hle-10.130464d0)

        hee=hbe2*(1d0-x)**(hbe2-1d0)*sqrt(max(0d0,hde))-

     &  0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*(-4d0*x1l+3d0*xl)-

     &  4d0*xl/(1d0-x)-5d0-x)

      ELSE

        hee=hbe2*(1d0-x)**(hbe2-1d0)*exp(0.172784d0*hbe2)/

     &  pygamm(1d0+hbe2)-0.5d0*hbe2*(1d0+x)+hbe2**2/8d0*((1d0+x)*

     &  (-4d0*x1l+3d0*xl)-4d0*xl/(1d0-x)-5d0-x)

      ENDIF

      IF(x.GT.0.9999d0.AND.x.LE.0.999999d0) THEN

        hee=hee*100d0**hbe2/(100d0**hbe2-1d0)

      ELSEIF(x.GT.0.999999d0) THEN

        hee=0d0

      ENDIF

      xpel(11)=x*hee


C...Photon and (transverse) W- inside electron.

      aemp=pyalem(pme*sqrt(max(0d0,q2)))/paru(2)

      IF(mstp(13).LE.1) THEN

        hlg=hle

      ELSE

        hlg=log(max(1d0,(parp(13)/pme**2)*(1d0-x)/x**2))

      ENDIF

      xpel(22)=aemp*hlg*(1d0+(1d0-x)**2)

      hlw=log(1d0+q2/pmas(24,1)**2)/(4d0*paru(102))

      xpel(-24)=aemp*hlw*(1d0+(1d0-x)**2)


C...Electron or positron inside photon inside electron.

      IF(mstp(12).EQ.1) THEN

        xfsea=0.5d0*(aemp*(hle-1d0))**2*(4d0/3d0+x-x**2-4d0*x**3/3d0+

     &  2d0*x*(1d0+x)*xl)

        xpel(11)=xpel(11)+xfsea

        xpel(-11)=xfsea


C...Initialize PDFLIB photon parton distributions.

        IF(mstp(56).EQ.2) THEN

          parm(1)='NPTYPE'

          value(1)=3

          parm(2)='NGROUP'

          value(2)=mstp(55)/1000

          parm(3)='NSET'

          value(3)=mod(mstp(55),1000)

          IF(mint(93).NE.3000000+mstp(55)) THEN

            CALL pdfset(parm,value)

            mint(93)=3000000+mstp(55)

          ENDIF

        ENDIF


C...Quarks and gluons inside photon inside electron:

C...numerical convolution required.

        DO 110 kfl=0,6

          sxp(kfl)=0d0

  110   CONTINUE

        sumxpp=0d0

        iter=-1

  120   iter=iter+1

        sumxp=sumxpp

        nstp=2**(iter-1)

        IF(iter.EQ.0) nstp=2

        DO 130 kfl=0,6

          sxp(kfl)=0.5d0*sxp(kfl)

  130   CONTINUE

        wtstp=0.5d0/nstp

        IF(iter.EQ.0) wtstp=0.5d0

C...Pick grid of x_{gamma} values logarithmically even.

        DO 150 istp=1,nstp

          IF(iter.EQ.0) THEN

            xle=xl*(istp-1)

          ELSE

            xle=xl*(istp-0.5d0)/nstp

          ENDIF

          xe=min(0.999999d0,exp(xle))

          xg=min(0.999999d0,x/xe)

C...Evaluate photon inside electron parton distribution for convolution.

          xpgp=1d0+(1d0-xe)**2

          IF(mstp(13).LE.1) THEN

            xpgp=xpgp*hle

          ELSE

            xpgp=xpgp*log(max(1d0,(parp(13)/pme**2)*(1d0-xe)/xe**2))

          ENDIF

C...Evaluate photon parton distributions for convolution.

          IF(mstp(56).EQ.1) THEN

            CALL pypdga(xg,q2,xpga)

            DO 140 kfl=0,5

              sxp(kfl)=sxp(kfl)+wtstp*xpgp*xpga(kfl)

  140       CONTINUE

          ELSEIF(mstp(56).EQ.2) THEN

C...Call PDFLIB parton distributions.

            xx=xg

            qq=sqrt(max(0d0,q2min,q2))

            IF(mstp(57).EQ.0) qq=sqrt(q2min)

            CALL structm(xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu)

            sxp(0)=sxp(0)+wtstp*xpgp*glu

            sxp(1)=sxp(1)+wtstp*xpgp*dnv

            sxp(2)=sxp(2)+wtstp*xpgp*upv

            sxp(3)=sxp(3)+wtstp*xpgp*str

            sxp(4)=sxp(4)+wtstp*xpgp*chm

            sxp(5)=sxp(5)+wtstp*xpgp*bot

            sxp(6)=sxp(6)+wtstp*xpgp*top

          ENDIF

  150   CONTINUE

        sumxpp=sxp(0)+2d0*sxp(1)+2d0*sxp(2)

        IF(iter.LE.2.OR.(iter.LE.7.AND.abs(sumxpp-sumxp).GT.

     &  parp(14)*(sumxpp+sumxp))) goto 120


C...Put convolution into output arrays.

        fconv=aemp*(-xl)

        xpel(0)=fconv*sxp(0)

        DO 160 kfl=1,6

          xpel(kfl)=fconv*sxp(kfl)

          xpel(-kfl)=xpel(kfl)

  160   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYPDGA

C...Gives photon parton distribution.


      SUBROUTINE pypdga(X,Q2,XPGA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pypars/,/pyint1/

C...Local arrays.

      dimension xpga(-6:6),dgag(4,3),dgbg(4,3),dgcg(4,3),dgan(4,3),

     &dgbn(4,3),dgcn(4,3),dgdn(4,3),dgen(4,3),dgas(4,3),dgbs(4,3),

     &dgcs(4,3),dgds(4,3),dges(4,3)


C...The following data lines are coefficients needed in the

C...Drees and Grassie photon parton distribution parametrization.

      DATA dgag/-.207d0,.6158d0,1.074d0,0.d0,.8926d-2,.6594d0,

     &.4766d0,.1975d-1,.03197d0,1.018d0,.2461d0,.2707d-1/

      DATA dgbg/-.1987d0,.6257d0,8.352d0,5.024d0,.5085d-1,.2774d0,

     &-.3906d0,-.3212d0,-.618d-2,.9476d0,-.6094d0,-.1067d-1/

      DATA dgcg/5.119d0,-.2752d0,-6.993d0,2.298d0,-.2313d0,.1382d0,

     &6.542d0,.5162d0,-.1216d0,.9047d0,2.653d0,.2003d-2/

      DATA dgan/2.285d0,-.1526d-1,1330.d0,4.219d0,-.3711d0,1.061d0,

     &4.758d0,-.1503d-1,15.8d0,-.9464d0,-.5d0,-.2118d0/

      DATA dgbn/6.073d0,-.8132d0,-41.31d0,3.165d0,-.1717d0,.7815d0,

     &1.535d0,.7067d-2,2.742d0,-.7332d0,.7148d0,3.287d0/

      DATA dgcn/-.4202d0,.1778d-1,.9216d0,.18d0,.8766d-1,.2197d-1,

     &.1096d0,.204d0,.2917d-1,.4657d-1,.1785d0,.4811d-1/

      DATA dgdn/-.8083d-1,.6346d0,1.208d0,.203d0,-.8915d0,.2857d0,

     &2.973d0,.1185d0,-.342d-1,.7196d0,.7338d0,.8139d-1/

      DATA dgen/.5526d-1,1.136d0,.9512d0,.1163d-1,-.1816d0,.5866d0,

     &2.421d0,.4059d0,-.2302d-1,.9229d0,.5873d0,-.79d-4/

      DATA dgas/16.69d0,-.7916d0,1099.d0,4.428d0,-.1207d0,1.071d0,

     &1.977d0,-.8625d-2,6.734d0,-1.008d0,-.8594d-1,.7625d-1/

      DATA dgbs/.176d0,.4794d-1,1.047d0,.25d-1,25.d0,-1.648d0,

     &-.1563d-1,6.438d0,59.88d0,-2.983d0,4.48d0,.9686d0/

      DATA dgcs/-.208d-1,.3386d-2,4.853d0,.8404d0,-.123d-1,1.162d0,

     &.4824d0,-.11d-1,-.3226d-2,.8432d0,.3616d0,.1383d-2/

      DATA dgds/-.1685d-1,1.353d0,1.426d0,1.239d0,-.9194d-1,.7912d0,

     &.6397d0,2.327d0,-.3321d-1,.9475d0,-.3198d0,.2132d-1/

      DATA dges/-.1986d0,1.1d0,1.136d0,-.2779d0,.2015d-1,.9869d0,

     &-.7036d-1,.1694d-1,.1059d0,.6954d0,-.6663d0,.3683d0/


C...Photon parton distribution from Drees and Grassie.

C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.

      DO 100 kfl=-6,6

        xpga(kfl)=0d0

  100 CONTINUE

      vint(231)=1d0

      IF(mstp(57).LE.0) THEN

        t=log(1d0/0.16d0)

      ELSE

        t=log(min(1d4,max(1d0,q2))/0.16d0)

      ENDIF

      x1=1d0-x

      nf=3

      IF(q2.GT.25d0) nf=4

      IF(q2.GT.300d0) nf=5

      nfe=nf-2

      aem=paru(101)


C...Evaluate gluon content.

      dga=dgag(1,nfe)*t**dgag(2,nfe)+dgag(3,nfe)*t**(-dgag(4,nfe))

      dgb=dgbg(1,nfe)*t**dgbg(2,nfe)+dgbg(3,nfe)*t**(-dgbg(4,nfe))

      dgc=dgcg(1,nfe)*t**dgcg(2,nfe)+dgcg(3,nfe)*t**(-dgcg(4,nfe))

      xpgl=dga*x**dgb*x1**dgc


C...Evaluate up- and down-type quark content.

      dga=dgan(1,nfe)*t**dgan(2,nfe)+dgan(3,nfe)*t**(-dgan(4,nfe))

      dgb=dgbn(1,nfe)*t**dgbn(2,nfe)+dgbn(3,nfe)*t**(-dgbn(4,nfe))

      dgc=dgcn(1,nfe)*t**dgcn(2,nfe)+dgcn(3,nfe)*t**(-dgcn(4,nfe))

      dgd=dgdn(1,nfe)*t**dgdn(2,nfe)+dgdn(3,nfe)*t**(-dgdn(4,nfe))

      dge=dgen(1,nfe)*t**dgen(2,nfe)+dgen(3,nfe)*t**(-dgen(4,nfe))

      xpqn=x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge

      dga=dgas(1,nfe)*t**dgas(2,nfe)+dgas(3,nfe)*t**(-dgas(4,nfe))

      dgb=dgbs(1,nfe)*t**dgbs(2,nfe)+dgbs(3,nfe)*t**(-dgbs(4,nfe))

      dgc=dgcs(1,nfe)*t**dgcs(2,nfe)+dgcs(3,nfe)*t**(-dgcs(4,nfe))

      dgd=dgds(1,nfe)*t**dgds(2,nfe)+dgds(3,nfe)*t**(-dgds(4,nfe))

      dge=dges(1,nfe)*t**dges(2,nfe)+dges(3,nfe)*t**(-dges(4,nfe))

      dgf=9d0

      IF(nf.EQ.4) dgf=10d0

      IF(nf.EQ.5) dgf=55d0/6d0

      xpqs=dgf*x*(x**2+x1**2)/(dga-dgb*log(x1))+dgc*x**dgd*x1**dge

      IF(nf.LE.3) THEN

        xpqu=(xpqs+9d0*xpqn)/6d0

        xpqd=(xpqs-4.5d0*xpqn)/6d0

      ELSEIF(nf.EQ.4) THEN

        xpqu=(xpqs+6d0*xpqn)/8d0

        xpqd=(xpqs-6d0*xpqn)/8d0

      ELSE

        xpqu=(xpqs+7.5d0*xpqn)/10d0

        xpqd=(xpqs-5d0*xpqn)/10d0

      ENDIF


C...Put into output arrays.

      xpga(0)=aem*xpgl

      xpga(1)=aem*xpqd

      xpga(2)=aem*xpqu

      xpga(3)=aem*xpqd

      IF(nf.GE.4) xpga(4)=aem*xpqu

      IF(nf.GE.5) xpga(5)=aem*xpqd

      DO 110 kfl=1,6

        xpga(-kfl)=xpga(kfl)

  110 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYGGAM

C...Constructs the F2 and parton distributions of the photon

C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.

C...For F2, c and b are included by the Bethe-Heitler formula;

C...in the 'MSbar' scheme additionally a Cgamma term is added.

C...Contains the SaS sets 1D, 1M, 2D and 2M.

C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.


      SUBROUTINE pyggam(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),

     &xpdir(-6:6)

      common/pyint9/vxpvmd(-6:6),vxpanl(-6:6),vxpanh(-6:6),vxpdgm(-6:6)

      SAVE /pyint8/,/pyint9/

C...Local arrays.

      dimension xpdfgm(-6:6),xpga(-6:6), vxpga(-6:6)

C...Charm and bottom masses (low to compensate for J/psi etc.).

      DATA pmc/1.3d0/, pmb/4.6d0/

C...alpha_em and alpha_em/(2*pi).

      DATA aem/0.007297d0/, aem2pi/0.0011614d0/

C...Lambda value for 4 flavours.

      DATA alam/0.20d0/

C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.

      DATA fracu/0.8d0/

C...VMD couplings f_V**2/(4*pi).

      DATA frho/2.20d0/, fomega/23.6d0/, fphi/18.4d0/

C...Masses for rho (=omega) and phi.

      DATA pmrho/0.770d0/, pmphi/1.020d0/

C...Number of points in integration for IP2=1.

      DATA nstep/100/


C...Reset output.

      f2gm=0d0

      DO 100 kfl=-6,6

        xpdfgm(kfl)=0d0

        xpvmd(kfl)=0d0

        xpanl(kfl)=0d0

        xpanh(kfl)=0d0

        xpbeh(kfl)=0d0

        xpdir(kfl)=0d0

        vxpvmd(kfl)=0d0

        vxpanl(kfl)=0d0

        vxpanh(kfl)=0d0

        vxpdgm(kfl)=0d0

  100 CONTINUE


C...Set Q0 cut-off parameter as function of set used.

      IF(iset.LE.2) THEN

        q0=0.6d0

      ELSE

        q0=2d0

      ENDIF

      q02=q0**2


C...Scale choice for off-shell photon; common factors.

      q2a=q2

      facnor=1d0

      IF(ip2.EQ.1) THEN

        p2mx=p2+q02

        q2a=q2+p2*q02/max(q02,q2)

        facnor=log(q2/q02)/nstep

      ELSEIF(ip2.EQ.2) THEN

        p2mx=max(p2,q02)

      ELSEIF(ip2.EQ.3) THEN

        p2mx=p2+q02

        q2a=q2+p2*q02/max(q02,q2)

      ELSEIF(ip2.EQ.4) THEN

        p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/

     &  ((q2+p2)*(q02+p2)))

      ELSEIF(ip2.EQ.5) THEN

        p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/

     &  ((q2+p2)*(q02+p2)))

        p2mx=q0*sqrt(p2mxa)

        facnor=log(q2/p2mxa)/log(q2/p2mx)

      ELSEIF(ip2.EQ.6) THEN

        p2mx=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/

     &  ((q2+p2)*(q02+p2)))

        p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)

      ELSE

        p2mxa=q2*(q02+p2)/(q2+p2)*exp(p2*(q2-q02)/

     &  ((q2+p2)*(q02+p2)))

        p2mx=q0*sqrt(p2mxa)

        p2mxb=p2mx

        p2mx=max(0d0,1d0-p2/q2)*p2mx+min(1d0,p2/q2)*max(p2,q02)

        p2mxb=max(0d0,1d0-p2/q2)*p2mxb+min(1d0,p2/q2)*p2mxa

        facnor=log(q2/p2mxa)/log(q2/p2mxb)

      ENDIF


C...Call VMD parametrization for d quark and use to give rho, omega,

C...phi. Note dipole dampening for off-shell photon.

      CALL pygvmd(iset,1,x,q2a,p2mx,alam,xpga,vxpga)

      xfval=vxpga(1)

      xpga(1)=xpga(2)

      xpga(-1)=xpga(-2)

      facud=aem*(1d0/frho+1d0/fomega)*(pmrho**2/(pmrho**2+p2))**2

      facs=aem*(1d0/fphi)*(pmphi**2/(pmphi**2+p2))**2

      DO 110 kfl=-5,5

        xpvmd(kfl)=(facud+facs)*xpga(kfl)

  110 CONTINUE

      xpvmd(1)=xpvmd(1)+(1d0-fracu)*facud*xfval

      xpvmd(2)=xpvmd(2)+fracu*facud*xfval

      xpvmd(3)=xpvmd(3)+facs*xfval

      xpvmd(-1)=xpvmd(-1)+(1d0-fracu)*facud*xfval

      xpvmd(-2)=xpvmd(-2)+fracu*facud*xfval

      xpvmd(-3)=xpvmd(-3)+facs*xfval

      vxpvmd(1)=(1d0-fracu)*facud*xfval

      vxpvmd(2)=fracu*facud*xfval

      vxpvmd(3)=facs*xfval

      vxpvmd(-1)=(1d0-fracu)*facud*xfval

      vxpvmd(-2)=fracu*facud*xfval

      vxpvmd(-3)=facs*xfval


      IF(ip2.NE.1) THEN

C...Anomalous parametrizations for different strategies

C...for off-shell photons; except full integration.


C...Call anomalous parametrization for d + u + s.

        CALL pygano(-3,x,q2a,p2mx,alam,xpga,vxpga)

        DO 120 kfl=-5,5

          xpanl(kfl)=facnor*xpga(kfl)

          vxpanl(kfl)=facnor*vxpga(kfl)

  120   CONTINUE


C...Call anomalous parametrization for c and b.

        CALL pygano(4,x,q2a,p2mx,alam,xpga,vxpga)

        DO 130 kfl=-5,5

          xpanh(kfl)=facnor*xpga(kfl)

          vxpanh(kfl)=facnor*vxpga(kfl)

  130   CONTINUE

        CALL pygano(5,x,q2a,p2mx,alam,xpga,vxpga)

        DO 140 kfl=-5,5

          xpanh(kfl)=xpanh(kfl)+facnor*xpga(kfl)

          vxpanh(kfl)=vxpanh(kfl)+facnor*vxpga(kfl)

  140   CONTINUE


      ELSE

C...Special option: loop over flavours and integrate over k2.

        DO 170 kf=1,5

          DO 160 istep=1,nstep

            q2step=q02*(q2/q02)**((istep-0.5d0)/nstep)

            IF((kf.EQ.4.AND.q2step.LT.pmc**2).OR.

     &      (kf.EQ.5.AND.q2step.LT.pmb**2)) goto 160

            CALL pygvmd(0,kf,x,q2,q2step,alam,xpga,vxpga)

            facq=aem2pi*(q2step/(q2step+p2))**2*facnor

            IF(mod(kf,2).EQ.0) facq=facq*(8d0/9d0)

            IF(mod(kf,2).EQ.1) facq=facq*(2d0/9d0)

            DO 150 kfl=-5,5

              IF(kf.LE.3) xpanl(kfl)=xpanl(kfl)+facq*xpga(kfl)

              IF(kf.GE.4) xpanh(kfl)=xpanh(kfl)+facq*xpga(kfl)

              IF(kf.LE.3) vxpanl(kfl)=vxpanl(kfl)+facq*vxpga(kfl)

              IF(kf.GE.4) vxpanh(kfl)=vxpanh(kfl)+facq*vxpga(kfl)

  150       CONTINUE

  160     CONTINUE

  170   CONTINUE

      ENDIF


C...Call Bethe-Heitler term expression for charm and bottom.

      CALL pygbeh(4,x,q2,p2,pmc**2,xpbh)

      xpbeh(4)=xpbh

      xpbeh(-4)=xpbh

      CALL pygbeh(5,x,q2,p2,pmb**2,xpbh)

      xpbeh(5)=xpbh

      xpbeh(-5)=xpbh


C...For MSbar subtraction call C^gamma term expression for d, u, s.

      IF(iset.EQ.2.OR.iset.EQ.4) THEN

        CALL pygdir(x,q2,p2,q02,xpga)

        DO 180 kfl=-5,5

          xpdir(kfl)=xpga(kfl)

  180   CONTINUE

      ENDIF


C...Store result in output array.

      DO 190 kfl=-5,5

        chsq=1d0/9d0

        IF(iabs(kfl).EQ.2.OR.iabs(kfl).EQ.4) chsq=4d0/9d0

        xpf2=xpvmd(kfl)+xpanl(kfl)+xpbeh(kfl)+xpdir(kfl)

        IF(kfl.NE.0) f2gm=f2gm+chsq*xpf2

        xpdfgm(kfl)=xpvmd(kfl)+xpanl(kfl)+xpanh(kfl)

        vxpdgm(kfl)=vxpvmd(kfl)+vxpanl(kfl)+vxpanh(kfl)

  190 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYGVMD

C...Evaluates the VMD parton distributions of a photon,

C...evolved homogeneously from an initial scale P2 to Q2.

C...Does not include dipole suppression factor.

C...ISET is parton distribution set, see above;

C...additionally ISET=0 is used for the evolution of an anomalous photon

C...which branched at a scale P2 and then evolved homogeneously to Q2.

C...ALAM is the 4-flavour Lambda, which is automatically converted

C...to 3- and 5-flavour equivalents as needed.

C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.


      SUBROUTINE pygvmd(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Local arrays and data.

      dimension xpga(-6:6), vxpga(-6:6)

      DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/


C...Reset output.

      DO 100 kfl=-6,6

        xpga(kfl)=0d0

        vxpga(kfl)=0d0

  100 CONTINUE

      kfa=iabs(kf)


C...Calculate Lambda; protect against unphysical Q2 and P2 input.

      alam3=alam*(pmc/alam)**(2d0/27d0)

      alam5=alam*(alam/pmb)**(2d0/23d0)

      p2eff=max(p2,1.2d0*alam3**2)

      IF(kfa.EQ.4) p2eff=max(p2eff,pmc**2)

      IF(kfa.EQ.5) p2eff=max(p2eff,pmb**2)

      q2eff=max(q2,p2eff)


C...Find number of flavours at lower and upper scale.

      nfp=4

      IF(p2eff.LT.pmc**2) nfp=3

      IF(p2eff.GT.pmb**2) nfp=5

      nfq=4

      IF(q2eff.LT.pmc**2) nfq=3

      IF(q2eff.GT.pmb**2) nfq=5


C...Find s as sum of 3-, 4- and 5-flavour parts.

      s=0d0

      IF(nfp.EQ.3) THEN

        q2div=pmc**2

        IF(nfq.EQ.3) q2div=q2eff

        s=s+(6d0/27d0)*log(log(q2div/alam3**2)/log(p2eff/alam3**2))

      ENDIF

      IF(nfp.LE.4.AND.nfq.GE.4) THEN

        p2div=p2eff

        IF(nfp.EQ.3) p2div=pmc**2

        q2div=q2eff

        IF(nfq.EQ.5) q2div=pmb**2

        s=s+(6d0/25d0)*log(log(q2div/alam**2)/log(p2div/alam**2))

      ENDIF

      IF(nfq.EQ.5) THEN

        p2div=pmb**2

        IF(nfp.EQ.5) p2div=p2eff

        s=s+(6d0/23d0)*log(log(q2eff/alam5**2)/log(p2div/alam5**2))

      ENDIF


C...Calculate frequent combinations of x and s.

      x1=1d0-x

      xl=-log(x)

      s2=s**2

      s3=s**3

      s4=s**4


C...Evaluate homogeneous anomalous parton distributions below or

C...above threshold.

      IF(iset.EQ.0) THEN

        IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.

     &  (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN

          xval = x * 1.5d0 * (x**2+x1**2)

          xglu = 0d0

          xsea = 0d0

        ELSE

          xval = (1.5d0/(1d0-0.197d0*s+4.33d0*s2)*x**2 +

     &    (1.5d0+2.10d0*s)/(1d0+3.29d0*s)*x1**2 +

     &    5.23d0*s/(1d0+1.17d0*s+19.9d0*s3)*x*x1) *

     &    x**(1d0/(1d0+1.5d0*s)) * (1d0-x**2)**(2.667d0*s)

          xglu = 4d0*s/(1d0+4.76d0*s+15.2d0*s2+29.3d0*s4) *

     &    x**(-2.03d0*s/(1d0+2.44d0*s)) * (x1*xl)**(1.333d0*s) *

     &    ((4d0*x**2+7d0*x+4d0)*x1/3d0 - 2d0*x*(1d0+x)*xl)

          xsea = s2/(1d0+4.54d0*s+8.19d0*s2+8.05d0*s3) *

     &    x**(-1.54d0*s/(1d0+1.29d0*s)) * x1**(2.667d0*s) *

     &    ((8d0-73d0*x+62d0*x**2)*x1/9d0 + (3d0-8d0*x**2/3d0)*x*xl +

     &    (2d0*x-1d0)*x*xl**2)

        ENDIF


C...Evaluate set 1D parton distributions below or above threshold.

      ELSEIF(iset.EQ.1) THEN

        IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.

     &  (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN

          xval = 1.294d0 * x**0.80d0 * x1**0.76d0

          xglu = 1.273d0 * x**0.40d0 * x1**1.76d0

          xsea = 0.100d0 * x1**3.76d0

        ELSE

          xval = 1.294d0/(1d0+0.252d0*s+3.079d0*s2) *

     &    x**(0.80d0-0.13d0*s) * x1**(0.76d0+0.667d0*s) * xl**(2d0*s)

          xglu = 7.90d0*s/(1d0+5.50d0*s) * exp(-5.16d0*s) *

     &    x**(-1.90d0*s/(1d0+3.60d0*s)) * x1**1.30d0 *

     &    xl**(0.50d0+3d0*s) + 1.273d0 * exp(-10d0*s) *

     &    x**0.40d0 * x1**(1.76d0+3d0*s)

          xsea = (0.1d0-0.397d0*s2+1.121d0*s3)/

     &    (1d0+5.61d0*s2+5.26d0*s3) * x**(-7.32d0*s2/(1d0+10.3d0*s2)) *

     &    x1**((3.76d0+15d0*s+12d0*s2)/(1d0+4d0*s))

          xsea0 = 0.100d0 * x1**3.76d0

        ENDIF


C...Evaluate set 1M parton distributions below or above threshold.

      ELSEIF(iset.EQ.2) THEN

        IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.

     &  (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN

          xval = 0.8477d0 * x**0.51d0 * x1**1.37d0

          xglu = 3.42d0 * x**0.255d0 * x1**2.37d0

          xsea = 0d0

        ELSE

          xval = 0.8477d0/(1d0+1.37d0*s+2.18d0*s2+3.73d0*s3) *

     &    x**(0.51d0+0.21d0*s) * x1**1.37d0 * xl**(2.667d0*s)

          xglu = 24d0*s/(1d0+9.6d0*s+0.92d0*s2+14.34d0*s3) *

     &    exp(-5.94d0*s) * x**((-0.013d0-1.80d0*s)/(1d0+3.14d0*s)) *

     &    x1**(2.37d0+0.4d0*s) * xl**(0.32d0+3.6d0*s) + 3.42d0 *

     &    exp(-12d0*s) * x**0.255d0 * x1**(2.37d0+3d0*s)

          xsea = 0.842d0*s/(1d0+21.3d0*s-33.2d0*s2+229d0*s3) *

     &    x**((0.13d0-2.90d0*s)/(1d0+5.44d0*s)) * x1**(3.45d0+0.5d0*s) *

     &    xl**(2.8d0*s)

          xsea0 = 0d0

        ENDIF


C...Evaluate set 2D parton distributions below or above threshold.

      ELSEIF(iset.EQ.3) THEN

        IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.

     &  (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN

          xval = x**0.46d0 * x1**0.64d0 + 0.76d0 * x

          xglu = 1.925d0 * x1**2

          xsea = 0.242d0 * x1**4

        ELSE

          xval = (1d0+0.186d0*s)/(1d0-0.209d0*s+1.495d0*s2) *

     &    x**(0.46d0+0.25d0*s) *

     &    x1**((0.64d0+0.14d0*s+5d0*s2)/(1d0+s)) * xl**(1.9d0*s) +

     &    (0.76d0+0.4d0*s) * x * x1**(2.667d0*s)

          xglu = (1.925d0+5.55d0*s+147d0*s2)/(1d0-3.59d0*s+3.32d0*s2) *

     &    exp(-18.67d0*s) *

     &    x**((-5.81d0*s-5.34d0*s2)/(1d0+29d0*s-4.26d0*s2))

     &    * x1**((2d0-5.9d0*s)/(1d0+1.7d0*s)) *

     &    xl**(9.3d0*s/(1d0+1.7d0*s))

          xsea = (0.242d0-0.252d0*s+1.19d0*s2)/

     &    (1d0-0.607d0*s+21.95d0*s2) *

     &    x**(-12.1d0*s2/(1d0+2.62d0*s+16.7d0*s2)) * x1**4 * xl**s

          xsea0 = 0.242d0 * x1**4

        ENDIF


C...Evaluate set 2M parton distributions below or above threshold.

      ELSEIF(iset.EQ.4) THEN

        IF(q2.LE.p2.OR.(kfa.EQ.4.AND.q2.LT.pmc**2).OR.

     &  (kfa.EQ.5.AND.q2.LT.pmb**2)) THEN

          xval = 1.168d0 * x**0.50d0 * x1**2.60d0 + 0.965d0 * x

          xglu = 1.808d0 * x1**2

          xsea = 0.209d0 * x1**4

        ELSE

          xval = (1.168d0+1.771d0*s+29.35d0*s2) * exp(-5.776d0*s) *

     &    x**((0.5d0+0.208d0*s)/(1d0-0.794d0*s+1.516d0*s2)) *

     &    x1**((2.6d0+7.6d0*s)/(1d0+5d0*s)) *

     &    xl**(5.15d0*s/(1d0+2d0*s)) +

     &    (0.965d0+22.35d0*s)/(1d0+18.4d0*s) * x * x1**(2.667d0*s)

          xglu = (1.808d0+29.9d0*s)/(1d0+26.4d0*s) * exp(-5.28d0*s) *

     &    x**((-5.35d0*s-10.11d0*s2)/(1d0+31.71d0*s)) *

     &    x1**((2d0-7.3d0*s+4d0*s2)/(1d0+2.5d0*s)) *

     &    xl**(10.9d0*s/(1d0+2.5d0*s))

          xsea = (0.209d0+0.644d0*s2)/(1d0+0.319d0*s+17.6d0*s2) *

     &    x**((-0.373d0*s-7.71d0*s2)/(1d0+0.815d0*s+11.0d0*s2)) *

     &    x1**(4d0+s) * xl**(0.45d0*s)

          xsea0 = 0.209d0 * x1**4

        ENDIF

      ENDIF


C...Threshold factors for c and b sea.

      sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))

      xchm=0d0

      IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN

        sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))

        IF(iset.EQ.0) THEN

          xchm=xsea*(1d0-(sch/sll)**2)

        ELSE

          xchm=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sch/sll)

        ENDIF

      ENDIF

      xbot=0d0

      IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN

        sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))

        IF(iset.EQ.0) THEN

          xbot=xsea*(1d0-(sbt/sll)**2)

        ELSE

          xbot=max(0d0,xsea-xsea0*x1**(2.667d0*s))*(1d0-sbt/sll)

        ENDIF

      ENDIF


C...Fill parton distributions.

      xpga(0)=xglu

      xpga(1)=xsea

      xpga(2)=xsea

      xpga(3)=xsea

      xpga(4)=xchm

      xpga(5)=xbot

      xpga(kfa)=xpga(kfa)+xval

      DO 110 kfl=1,5

        xpga(-kfl)=xpga(kfl)

  110 CONTINUE

      vxpga(kfa)=xval

      vxpga(-kfa)=xval


      RETURN

      END


C*********************************************************************


C...PYGANO

C...Evaluates the parton distributions of the anomalous photon,

C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.

C...KF=0 gives the sum over (up to) 5 flavours,

C...KF<0 limits to flavours up to abs(KF),

C...KF>0 is for flavour KF only.

C...ALAM is the 4-flavour Lambda, which is automatically converted

C...to 3- and 5-flavour equivalents as needed.

C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.


      SUBROUTINE pygano(KF,X,Q2,P2,ALAM,XPGA,VXPGA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Local arrays and data.

      dimension xpga(-6:6), vxpga(-6:6), alamsq(3:5)

      DATA pmc/1.3d0/, pmb/4.6d0/, aem/0.007297d0/, aem2pi/0.0011614d0/


C...Reset output.

      DO 100 kfl=-6,6

        xpga(kfl)=0d0

        vxpga(kfl)=0d0

  100 CONTINUE

      IF(q2.LE.p2) RETURN

      kfa=iabs(kf)


C...Calculate Lambda; protect against unphysical Q2 and P2 input.

      alamsq(3)=(alam*(pmc/alam)**(2d0/27d0))**2

      alamsq(4)=alam**2

      alamsq(5)=(alam*(alam/pmb)**(2d0/23d0))**2

      p2eff=max(p2,1.2d0*alamsq(3))

      IF(kf.EQ.4) p2eff=max(p2eff,pmc**2)

      IF(kf.EQ.5) p2eff=max(p2eff,pmb**2)

      q2eff=max(q2,p2eff)

      xl=-log(x)


C...Find number of flavours at lower and upper scale.

      nfp=4

      IF(p2eff.LT.pmc**2) nfp=3

      IF(p2eff.GT.pmb**2) nfp=5

      nfq=4

      IF(q2eff.LT.pmc**2) nfq=3

      IF(q2eff.GT.pmb**2) nfq=5


C...Define range of flavour loop.

      IF(kf.EQ.0) THEN

        kflmn=1

        kflmx=5

      ELSEIF(kf.LT.0) THEN

        kflmn=1

        kflmx=kfa

      ELSE

        kflmn=kfa

        kflmx=kfa

      ENDIF


C...Loop over flavours the photon can branch into.

      DO 110 kfl=kflmn,kflmx


C...Light flavours: calculate t range and (approximate) s range.

        IF(kfl.LE.3.AND.(kfl.EQ.1.OR.kfl.EQ.kf)) THEN

          tdiff=log(q2eff/p2eff)

          s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/

     &    log(p2eff/alamsq(nfq)))

          IF(nfq.GT.nfp) THEN

            q2div=pmb**2

            IF(nfq.EQ.4) q2div=pmc**2

            snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/

     &      log(p2eff/alamsq(nfq)))

            snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/

     &      log(p2eff/alamsq(nfq-1)))

            s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)

          ENDIF

          IF(nfq.EQ.5.AND.nfp.EQ.3) THEN

            q2div=pmc**2

            snf4=(6d0/(33d0-2d0*4))*log(log(q2div/alamsq(4))/

     &      log(p2eff/alamsq(4)))

            snf3=(6d0/(33d0-2d0*3))*log(log(q2div/alamsq(3))/

     &      log(p2eff/alamsq(3)))

            s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snf3-snf4)

          ENDIF


C...u and s quark do not need a separate treatment when d has been done.

        ELSEIF(kfl.EQ.2.OR.kfl.EQ.3) THEN


C...Charm: as above, but only include range above c threshold.

        ELSEIF(kfl.EQ.4) THEN

          IF(q2.LE.pmc**2) goto 110

          p2eff=max(p2eff,pmc**2)

          q2eff=max(q2eff,p2eff)

          tdiff=log(q2eff/p2eff)

          s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/

     &    log(p2eff/alamsq(nfq)))

          IF(nfq.EQ.5.AND.nfp.EQ.4) THEN

            q2div=pmb**2

            snfq=(6d0/(33d0-2d0*nfq))*log(log(q2div/alamsq(nfq))/

     &      log(p2eff/alamsq(nfq)))

            snfp=(6d0/(33d0-2d0*(nfq-1)))*log(log(q2div/alamsq(nfq-1))/

     &      log(p2eff/alamsq(nfq-1)))

            s=s+(log(q2div/p2eff)/log(q2eff/p2eff))*(snfp-snfq)

          ENDIF


C...Bottom: as above, but only include range above b threshold.

        ELSEIF(kfl.EQ.5) THEN

          IF(q2.LE.pmb**2) goto 110

          p2eff=max(p2eff,pmb**2)

          q2eff=max(q2,p2eff)

          tdiff=log(q2eff/p2eff)

          s=(6d0/(33d0-2d0*nfq))*log(log(q2eff/alamsq(nfq))/

     &    log(p2eff/alamsq(nfq)))

        ENDIF


C...Evaluate flavour-dependent prefactor (charge^2 etc.).

        chsq=1d0/9d0

        IF(kfl.EQ.2.OR.kfl.EQ.4) chsq=4d0/9d0

        fac=aem2pi*2d0*chsq*tdiff


C...Evaluate parton distributions (normalized to unit momentum sum).

        IF(kfl.EQ.1.OR.kfl.EQ.4.OR.kfl.EQ.5.OR.kfl.EQ.kf) THEN

          xval= ((1.5d0+2.49d0*s+26.9d0*s**2)/(1d0+32.3d0*s**2)*x**2 +

     &    (1.5d0-0.49d0*s+7.83d0*s**2)/(1d0+7.68d0*s**2)*(1d0-x)**2 +

     &    1.5d0*s/(1d0-3.2d0*s+7d0*s**2)*x*(1d0-x)) *

     &    x**(1d0/(1d0+0.58d0*s)) * (1d0-x**2)**(2.5d0*s/(1d0+10d0*s))

          xglu= 2d0*s/(1d0+4d0*s+7d0*s**2) *

     &    x**(-1.67d0*s/(1d0+2d0*s)) * (1d0-x**2)**(1.2d0*s) *

     &    ((4d0*x**2+7d0*x+4d0)*(1d0-x)/3d0 - 2d0*x*(1d0+x)*xl)

          xsea= 0.333d0*s**2/(1d0+4.90d0*s+4.69d0*s**2+21.4d0*s**3) *

     &    x**(-1.18d0*s/(1d0+1.22d0*s)) * (1d0-x)**(1.2d0*s) *

     &    ((8d0-73d0*x+62d0*x**2)*(1d0-x)/9d0 +

     &    (3d0-8d0*x**2/3d0)*x*xl + (2d0*x-1d0)*x*xl**2)


C...Threshold factors for c and b sea.

          sll=log(log(q2eff/alam**2)/log(p2eff/alam**2))

          xchm=0d0

          IF(q2.GT.pmc**2.AND.q2.GT.1.001d0*p2eff) THEN

            sch=max(0d0,log(log(pmc**2/alam**2)/log(p2eff/alam**2)))

            xchm=xsea*(1d0-(sch/sll)**3)

          ENDIF

          xbot=0d0

          IF(q2.GT.pmb**2.AND.q2.GT.1.001d0*p2eff) THEN

            sbt=max(0d0,log(log(pmb**2/alam**2)/log(p2eff/alam**2)))

            xbot=xsea*(1d0-(sbt/sll)**3)

          ENDIF

        ENDIF


C...Add contribution of each valence flavour.

        xpga(0)=xpga(0)+fac*xglu

        xpga(1)=xpga(1)+fac*xsea

        xpga(2)=xpga(2)+fac*xsea

        xpga(3)=xpga(3)+fac*xsea

        xpga(4)=xpga(4)+fac*xchm

        xpga(5)=xpga(5)+fac*xbot

        xpga(kfl)=xpga(kfl)+fac*xval

        vxpga(kfl)=vxpga(kfl)+fac*xval

  110 CONTINUE

      DO 120 kfl=1,5

        xpga(-kfl)=xpga(kfl)

        vxpga(-kfl)=vxpga(kfl)

  120 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYGBEH

C...Evaluates the Bethe-Heitler cross section for heavy flavour

C...production.

C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.


      SUBROUTINE pygbeh(KF,X,Q2,P2,PM2,XPBH)

C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local data.

      DATA aem2pi/0.0011614d0/


C...Reset output.

      xpbh=0d0

      sigbh=0d0


C...Check kinematics limits.

      IF(x.GE.q2/(4d0*pm2+q2+p2)) RETURN

      w2=q2*(1d0-x)/x-p2

      beta2=1d0-4d0*pm2/w2

      IF(beta2.LT.1d-10) RETURN

      beta=sqrt(beta2)

      rmq=4d0*pm2/q2


C...Simple case: P2 = 0.

      IF(p2.LT.1d-4) THEN

        IF(beta.LT.0.99d0) THEN

          xbl=log((1d0+beta)/(1d0-beta))

        ELSE

          xbl=log((1d0+beta)**2*w2/(4d0*pm2))

        ENDIF

        sigbh=beta*(8d0*x*(1d0-x)-1d0-rmq*x*(1d0-x))+

     &  xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)


C...Complicated case: P2 > 0, based on approximation of

C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373

      ELSE

        rpq=1d0-4d0*x**2*p2/q2

        IF(rpq.GT.1d-10) THEN

          rpbe=sqrt(rpq*beta2)

          IF(rpbe.LT.0.99d0) THEN

            xbl=log((1d0+rpbe)/(1d0-rpbe))

            xbi=2d0*rpbe/(1d0-rpbe**2)

          ELSE

            rpbesn=4d0*pm2/w2+(4d0*x**2*p2/q2)*beta2

            xbl=log((1d0+rpbe)**2/rpbesn)

            xbi=2d0*rpbe/rpbesn

          ENDIF

          sigbh=beta*(6d0*x*(1d0-x)-1d0)+

     &    xbl*(x**2+(1d0-x)**2+rmq*x*(1d0-3d0*x)-0.5d0*rmq**2*x**2)+

     &    xbi*(2d0*x/q2)*(pm2*x*(2d0-rmq)-p2*x)

        ENDIF

      ENDIF


C...Multiply by charge-squared etc. to get parton distribution.

      chsq=1d0/9d0

      IF(iabs(kf).EQ.2.OR.iabs(kf).EQ.4) chsq=4d0/9d0

      xpbh=3d0*chsq*aem2pi*x*sigbh


      RETURN

      END


C*********************************************************************


C...PYGDIR

C...Evaluates the direct contribution, i.e. the C^gamma term,

C...as needed in MSbar parametrizations.

C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.


      SUBROUTINE pygdir(X,Q2,P2,Q02,XPGA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Local array and data.

      dimension xpga(-6:6)

      DATA pmc/1.3d0/, pmb/4.6d0/, aem2pi/0.0011614d0/


C...Reset output.

      DO 100 kfl=-6,6

        xpga(kfl)=0d0

  100 CONTINUE


C...Evaluate common x-dependent expression.

      xtmp = (x**2+(1d0-x)**2) * (-log(x)) - 1d0

      cgam = 3d0*aem2pi*x * (xtmp*(1d0+p2/(p2+q02)) + 6d0*x*(1d0-x))


C...d, u, s part by simple charge factor.

      xpga(1)=(1d0/9d0)*cgam

      xpga(2)=(4d0/9d0)*cgam

      xpga(3)=(1d0/9d0)*cgam


C...Also fill for antiquarks.

      DO 110 kf=1,5

        xpga(-kf)=xpga(kf)

  110 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYPDPI

C...Gives pi+ parton distribution according to two different

C...parametrizations.


      SUBROUTINE pypdpi(X,Q2,XPPI)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pypars/,/pyint1/

C...Local arrays.

      dimension xppi(-6:6),cow(3,5,4,2),xq(9),ts(6)


C...The following data lines are coefficients needed in the

C...Owens pion parton distribution parametrizations, see below.

C...Expansion coefficients for up and down valence quark distributions.

      DATA ((cow(ip,is,1,1),is=1,5),ip=1,3)/

     &4.0000d-01,  7.0000d-01,  0.0000d+00,  0.0000d+00,  0.0000d+00,

     &-6.2120d-02,  6.4780d-01,  0.0000d+00,  0.0000d+00,  0.0000d+00,

     &-7.1090d-03,  1.3350d-02,  0.0000d+00,  0.0000d+00,  0.0000d+00/

      DATA ((cow(ip,is,1,2),is=1,5),ip=1,3)/

     &4.0000d-01,  6.2800d-01,  0.0000d+00,  0.0000d+00,  0.0000d+00,

     &-5.9090d-02,  6.4360d-01,  0.0000d+00,  0.0000d+00,  0.0000d+00,

     &-6.5240d-03,  1.4510d-02,  0.0000d+00,  0.0000d+00,  0.0000d+00/

C...Expansion coefficients for gluon distribution.

      DATA ((cow(ip,is,2,1),is=1,5),ip=1,3)/

     &8.8800d-01,  0.0000d+00,  3.1100d+00,  6.0000d+00,  0.0000d+00,

     &-1.8020d+00, -1.5760d+00, -1.3170d-01,  2.8010d+00, -1.7280d+01,

     &1.8120d+00,  1.2000d+00,  5.0680d-01, -1.2160d+01,  2.0490d+01/

      DATA ((cow(ip,is,2,2),is=1,5),ip=1,3)/

     &7.9400d-01,  0.0000d+00,  2.8900d+00,  6.0000d+00,  0.0000d+00,

     &-9.1440d-01, -1.2370d+00,  5.9660d-01, -3.6710d+00, -8.1910d+00,

     &5.9660d-01,  6.5820d-01, -2.5500d-01, -2.3040d+00,  7.7580d+00/

C...Expansion coefficients for (up+down+strange) quark sea distribution.

      DATA ((cow(ip,is,3,1),is=1,5),ip=1,3)/

     &9.0000d-01,  0.0000d+00,  5.0000d+00,  0.0000d+00,  0.0000d+00,

     &-2.4280d-01, -2.1200d-01,  8.6730d-01,  1.2660d+00,  2.3820d+00,

     &1.3860d-01,  3.6710d-03,  4.7470d-02, -2.2150d+00,  3.4820d-01/

      DATA ((cow(ip,is,3,2),is=1,5),ip=1,3)/

     &9.0000d-01,  0.0000d+00,  5.0000d+00,  0.0000d+00,  0.0000d+00,

     &-1.4170d-01, -1.6970d-01, -2.4740d+00, -2.5340d+00,  5.6210d-01,

     &-1.7400d-01, -9.6230d-02,  1.5750d+00,  1.3780d+00, -2.7010d-01/

C...Expansion coefficients for charm quark sea distribution.

      DATA ((cow(ip,is,4,1),is=1,5),ip=1,3)/

     &0.0000d+00, -2.2120d-02,  2.8940d+00,  0.0000d+00,  0.0000d+00,

     &7.9280d-02, -3.7850d-01,  9.4330d+00,  5.2480d+00,  8.3880d+00,

     &-6.1340d-02, -1.0880d-01, -1.0852d+01, -7.1870d+00, -1.1610d+01/

      DATA ((cow(ip,is,4,2),is=1,5),ip=1,3)/

     &0.0000d+00, -8.8200d-02,  1.9240d+00,  0.0000d+00,  0.0000d+00,

     &6.2290d-02, -2.8920d-01,  2.4240d-01, -4.4630d+00, -8.3670d-01,

     &-4.0990d-02, -1.0820d-01,  2.0360d+00,  5.2090d+00, -4.8400d-02/


C...Euler's beta function, requires ordinary Gamma function

      eulbet(x,y)=pygamm(x)*pygamm(y)/pygamm(x+y)


C...Reset output array.

      DO 100 kfl=-6,6

        xppi(kfl)=0d0

  100 CONTINUE


      IF(mstp(53).LE.2) THEN

C...Pion parton distributions from Owens.

C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.


C...Determine set, Lambda and s expansion variable.

        nset=mstp(53)

        IF(nset.EQ.1) alam=0.2d0

        IF(nset.EQ.2) alam=0.4d0

        vint(231)=4d0

        IF(mstp(57).LE.0) THEN

          sd=0d0

        ELSE

          q2in=min(2d3,max(4d0,q2))

          sd=log(log(q2in/alam**2)/log(4d0/alam**2))

        ENDIF


C...Calculate parton distributions.

        DO 120 kfl=1,4

          DO 110 is=1,5

            ts(is)=cow(1,is,kfl,nset)+cow(2,is,kfl,nset)*sd+

     &      cow(3,is,kfl,nset)*sd**2

  110     CONTINUE

          IF(kfl.EQ.1) THEN

            xq(kfl)=x**ts(1)*(1d0-x)**ts(2)/eulbet(ts(1),ts(2)+1d0)

          ELSE

            xq(kfl)=ts(1)*x**ts(2)*(1d0-x)**ts(3)*(1d0+ts(4)*x+

     &      ts(5)*x**2)

          ENDIF

  120   CONTINUE


C...Put into output array.

        xppi(0)=xq(2)

        xppi(1)=xq(3)/6d0

        xppi(2)=xq(1)+xq(3)/6d0

        xppi(3)=xq(3)/6d0

        xppi(4)=xq(4)

        xppi(-1)=xq(1)+xq(3)/6d0

        xppi(-2)=xq(3)/6d0

        xppi(-3)=xq(3)/6d0

        xppi(-4)=xq(4)


C...Leading order pion parton distributions from Gluck, Reya and Vogt.

C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and

C...10^-5 < x < 1.

      ELSE


C...Determine s expansion variable and some x expressions.

        vint(231)=0.25d0

        IF(mstp(57).LE.0) THEN

          sd=0d0

        ELSE

          q2in=min(1d8,max(0.25d0,q2))

          sd=log(log(q2in/0.232d0**2)/log(0.25d0/0.232d0**2))

        ENDIF

        sd2=sd**2

        xl=-log(x)

        xs=sqrt(x)


C...Evaluate valence, gluon and sea distributions.

        xfval=(0.519d0+0.180d0*sd-0.011d0*sd2)*x**(0.499d0-0.027d0*sd)*

     &  (1d0+(0.381d0-0.419d0*sd)*xs)*(1d0-x)**(0.367d0+0.563d0*sd)

        xfglu=(x**(0.482d0+0.341d0*sqrt(sd))*((0.678d0+0.877d0*

     &  sd-0.175d0*sd2)+

     &  (0.338d0-1.597d0*sd)*xs+(-0.233d0*sd+0.406d0*sd2)*x)+

     &  sd**0.599d0*exp(-(0.618d0+2.070d0*sd)+sqrt(3.676d0*sd**1.263d0*

     &  xl)))*

     &  (1d0-x)**(0.390d0+1.053d0*sd)

        xfsea=sd**0.55d0*(1d0-0.748d0*xs+(0.313d0+0.935d0*sd)*x)*(1d0-

     &  x)**3.359d0*

     &  exp(-(4.433d0+1.301d0*sd)+sqrt((9.30d0-0.887d0*sd)*sd**0.56d0*

     &  xl))/

     &  xl**(2.538d0-0.763d0*sd)

        IF(sd.LE.0.888d0) THEN

          xfchm=0d0

        ELSE

          xfchm=(sd-0.888d0)**1.02d0*(1d0+1.008d0*x)*(1d0-x)**(1.208d0+

     &    0.771d0*sd)*

     &    exp(-(4.40d0+1.493d0*sd)+sqrt((2.032d0+1.901d0*sd)*sd**0.39d0*

     &    xl))

        ENDIF

        IF(sd.LE.1.351d0) THEN

          xfbot=0d0

        ELSE

          xfbot=(sd-1.351d0)**1.03d0*(1d0-x)**(0.697d0+0.855d0*sd)*

     &    exp(-(4.51d0+1.490d0*sd)+sqrt((3.056d0+1.694d0*sd)*sd**0.39d0*

     &    xl))

        ENDIF


C...Put into output array.

        xppi(0)=xfglu

        xppi(1)=xfsea

        xppi(2)=xfsea

        xppi(3)=xfsea

        xppi(4)=xfchm

        xppi(5)=xfbot

        DO 130 kfl=1,5

          xppi(-kfl)=xppi(kfl)

  130   CONTINUE

        xppi(2)=xppi(2)+xfval

        xppi(-1)=xppi(-1)+xfval

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYPDPR

C...Gives proton parton distributions according to a few different

C...parametrizations.


      SUBROUTINE pypdpr(X,Q2,XPPR)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/

C...Arrays and data.

      dimension xppr(-6:6),q2min(6)

      DATA q2min/ 2.56d0, 2.56d0, 2.56d0, 0.4d0, 0.4d0, 0.4d0/


C...Reset output array.

      DO 100 kfl=-6,6

        xppr(kfl)=0d0

  100 CONTINUE


C...Common preliminaries.

      nset=max(1,min(6,mstp(51)))

      vint(231)=q2min(nset)

      IF(mstp(57).EQ.0) THEN

        q2l=q2min(nset)

      ELSE

        q2l=max(q2min(nset),q2)

      ENDIF


      IF(nset.GE.1.AND.nset.LE.3) THEN

C...Interface to the CTEQ 3 parton distributions.

        qrt=sqrt(max(1d0,q2l))


C...Loop over flavours.

        DO 110 i=-6,6

          IF(i.LE.0) THEN

            xppr(i)=pycteq(nset,i,x,qrt)

          ELSEIF(i.LE.2) THEN

            xppr(i)=pycteq(nset,i,x,qrt)+xppr(-i)

          ELSE

            xppr(i)=xppr(-i)

          ENDIF

  110   CONTINUE


      ELSEIF(nset.GE.4.AND.nset.LE.6) THEN

C...Interface to the GRV 94 distributions.

        IF(nset.EQ.4) THEN

          CALL pygrvl(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)

        ELSEIF(nset.EQ.5) THEN

          CALL pygrvm(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)

        ELSE

          CALL pygrvd(x, q2l, uv, dv, del, udb, sb, chm, bot, gl)

        ENDIF


C...Put into output array.

        xppr(0)=gl

        xppr(-1)=0.5d0*(udb+del)

        xppr(-2)=0.5d0*(udb-del)

        xppr(-3)=sb

        xppr(-4)=chm

        xppr(-5)=bot

        xppr(1)=dv+xppr(-1)

        xppr(2)=uv+xppr(-2)

        xppr(3)=sb

        xppr(4)=chm

        xppr(5)=bot


      ENDIF


      RETURN

      END


C*********************************************************************


C...PYCTEQ

C...Gives the CTEQ 3 parton distribution function sets in

C...parametrized form, of October 24, 1994.

C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,

C...J. Qiu, W.K. Tung and H. Weerts.


      FUNCTION pycteq (ISET, IPRT, X, Q)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)


C...Data on Lambda values of fits, minimum Q and quark masses.

      dimension alm(3), qms(4:6)

      DATA alm / 0.177d0, 0.239d0, 0.247d0 /

      DATA qmn / 1.60d0 /, (qms(i), i=4,6) / 1.60d0, 5.00d0, 180.0d0 /


C....Check flavour thresholds. Set up QI for SB.

      ip = iabs(iprt)

      IF(ip .GE. 4) THEN

        IF(q .LE. qms(ip)) THEN

          pycteq = 0d0

          RETURN

        ENDIF

        qi = qms(ip)

      ELSE

        qi = qmn

      ENDIF


C...Use "standard lambda" of parametrization program for expansion.

      alam = alm(iset)

      sbl = log(q/alam) / log(qi/alam)

      sb = log(sbl)

      sb2 = sb*sb

      sb3 = sb2*sb


C...Expansion for CTEQ3L.

      IF(iset .EQ. 1) THEN

        IF(iprt .EQ. 2) THEN

          a0=exp( 0.1907d+00+0.4205d-01*sb +0.2752d+00*sb2-

     &    0.3171d+00*sb3)

          a1= 0.4611d+00+0.2331d-01*sb -0.3403d-01*sb2+0.3174d-01*sb3

          a2= 0.3504d+01+0.5739d+00*sb +0.2676d+00*sb2-0.1553d+00*sb3

          a3= 0.7452d+01-0.6742d+01*sb +0.2849d+01*sb2-0.1964d+00*sb3

          a4= 0.1116d+01-0.3435d+00*sb +0.2865d+00*sb2-0.1288d+00*sb3

          a5= 0.6659d-01+0.2714d+00*sb -0.2688d+00*sb2+0.2763d+00*sb3

        ELSEIF(iprt .EQ. 1) THEN

          a0=exp( 0.1141d+00+0.4764d+00*sb -0.1745d+01*sb2+

     &    0.7728d+00*sb3)

          a1= 0.4275d+00-0.1290d+00*sb +0.3609d+00*sb2-0.1689d+00*sb3

          a2= 0.3000d+01+0.2946d+01*sb -0.4117d+01*sb2+0.1989d+01*sb3

          a3=-0.1302d+01+0.2322d+01*sb -0.4258d+01*sb2+0.2109d+01*sb3

          a4= 0.2586d+01-0.1920d+00*sb -0.3754d+00*sb2+0.2731d+00*sb3

          a5=-0.2251d+00-0.5374d+00*sb +0.2245d+01*sb2-0.1034d+01*sb3

        ELSEIF(iprt .EQ. 0) THEN

          a0=exp(-0.7631d+00-0.7241d+00*sb -0.1170d+01*sb2+

     &    0.5343d+00*sb3)

          a1=-0.3573d+00+0.3469d+00*sb -0.3396d+00*sb2+0.9188d-01*sb3

          a2= 0.5604d+01+0.7458d+00*sb -0.5082d+00*sb2+0.1844d+00*sb3

          a3= 0.1549d+02-0.1809d+02*sb +0.1162d+02*sb2-0.3483d+01*sb3

          a4= 0.9881d+00+0.1364d+00*sb -0.4421d+00*sb2+0.2051d+00*sb3

          a5=-0.9505d-01+0.3259d+01*sb -0.1547d+01*sb2+0.2918d+00*sb3

        ELSEIF(iprt .EQ. -1) THEN

          a0=exp(-0.2449d+01-0.3513d+01*sb +0.4529d+01*sb2-

     &    0.2031d+01*sb3)

          a1=-0.4050d+00+0.3411d+00*sb -0.3669d+00*sb2+0.1109d+00*sb3

          a2= 0.7470d+01-0.2982d+01*sb +0.5503d+01*sb2-0.2419d+01*sb3

          a3= 0.1503d+02+0.1638d+01*sb -0.8772d+01*sb2+0.3852d+01*sb3

          a4= 0.1137d+01-0.1006d+01*sb +0.1485d+01*sb2-0.6389d+00*sb3

          a5=-0.5299d+00+0.3160d+01*sb -0.3104d+01*sb2+0.1219d+01*sb3

        ELSEIF(iprt .EQ. -2) THEN

          a0=exp(-0.2740d+01-0.7987d-01*sb -0.9015d+00*sb2-

     &    0.9872d-01*sb3)

          a1=-0.3909d+00+0.1244d+00*sb -0.4487d-01*sb2+0.1277d-01*sb3

          a2= 0.9163d+01+0.2823d+00*sb -0.7720d+00*sb2-0.9360d-02*sb3

          a3= 0.1080d+02-0.3915d+01*sb -0.1153d+01*sb2+0.2649d+01*sb3

          a4= 0.9894d+00-0.1647d+00*sb -0.9426d-02*sb2+0.2945d-02*sb3

          a5=-0.3395d+00+0.6998d+00*sb +0.7000d+00*sb2-0.6730d-01*sb3

        ELSEIF(iprt .EQ. -3) THEN

          a0=exp(-0.3640d+01+0.1250d+01*sb -0.2914d+01*sb2+

     &    0.8390d+00*sb3)

          a1=-0.3595d+00-0.5259d-01*sb +0.3122d+00*sb2-0.1642d+00*sb3

          a2= 0.7305d+01+0.9727d+00*sb -0.9788d+00*sb2-0.5193d-01*sb3

          a3= 0.1198d+02-0.1799d+02*sb +0.2614d+02*sb2-0.1091d+02*sb3

          a4= 0.9882d+00-0.6101d+00*sb +0.9737d+00*sb2-0.4935d+00*sb3

          a5=-0.1186d+00-0.3231d+00*sb +0.3074d+01*sb2-0.1274d+01*sb3

        ELSEIF(iprt .EQ. -4) THEN

          a0=sb** 0.1122d+01*exp(-0.3718d+01-0.1335d+01*sb +

     &    0.1651d-01*sb2)

          a1=-0.4719d+00+0.7509d+00*sb -0.8420d+00*sb2+0.2901d+00*sb3

          a2= 0.6194d+01-0.1641d+01*sb +0.4907d+01*sb2-0.2523d+01*sb3

          a3= 0.4426d+01-0.4270d+01*sb +0.6581d+01*sb2-0.3474d+01*sb3

          a4= 0.2683d+00+0.9876d+00*sb -0.7612d+00*sb2+0.1780d+00*sb3

          a5=-0.4547d+00+0.4410d+01*sb -0.3712d+01*sb2+0.1245d+01*sb3

        ELSEIF(iprt .EQ. -5) THEN

          a0=sb** 0.9838d+00*exp(-0.2548d+01-0.7660d+01*sb +

     &    0.3702d+01*sb2)

          a1=-0.3122d+00-0.2120d+00*sb +0.5716d+00*sb2-0.3773d+00*sb3

          a2= 0.6257d+01-0.8214d-01*sb -0.2537d+01*sb2+0.2981d+01*sb3

          a3=-0.6723d+00+0.2131d+01*sb +0.9599d+01*sb2-0.7910d+01*sb3

          a4= 0.9169d-01+0.4295d-01*sb -0.5017d+00*sb2+0.3811d+00*sb3

          a5= 0.2402d+00+0.2656d+01*sb -0.1586d+01*sb2+0.2880d+00*sb3

        ELSEIF(iprt .EQ. -6) THEN

          a0=sb** 0.1001d+01*exp(-0.6934d+01+0.3050d+01*sb -

     &    0.6943d+00*sb2)

          a1=-0.1713d+00-0.5167d+00*sb +0.1241d+01*sb2-0.1703d+01*sb3

          a2= 0.6169d+01+0.3023d+01*sb -0.1972d+02*sb2+0.1069d+02*sb3

          a3= 0.4439d+01-0.1746d+02*sb +0.1225d+02*sb2+0.8350d+00*sb3

          a4= 0.5458d+00-0.4586d+00*sb +0.9089d+00*sb2-0.4049d+00*sb3

          a5= 0.3207d+01-0.3362d+01*sb +0.5877d+01*sb2-0.7659d+01*sb3

        ENDIF


C...Expansion for CTEQ3M.

      ELSEIF(iset .EQ. 2) THEN

        IF(iprt .EQ. 2) THEN

          a0=exp( 0.2259d+00+0.1237d+00*sb +0.3035d+00*sb2-

     &    0.2935d+00*sb3)

          a1= 0.5085d+00+0.1651d-01*sb -0.3592d-01*sb2+0.2782d-01*sb3

          a2= 0.3732d+01+0.4901d+00*sb +0.2218d+00*sb2-0.1116d+00*sb3

          a3= 0.7011d+01-0.6620d+01*sb +0.2557d+01*sb2-0.1360d+00*sb3

          a4= 0.8969d+00-0.2429d+00*sb +0.1811d+00*sb2-0.6888d-01*sb3

          a5= 0.8636d-01+0.2558d+00*sb -0.3082d+00*sb2+0.2535d+00*sb3

        ELSEIF(iprt .EQ. 1) THEN

          a0=exp(-0.7266d+00-0.1584d+01*sb +0.1259d+01*sb2-

     &    0.4305d-01*sb3)

          a1= 0.5285d+00-0.3721d+00*sb +0.5150d+00*sb2-0.1697d+00*sb3

          a2= 0.4075d+01+0.8282d+00*sb -0.4496d+00*sb2+0.2107d+00*sb3

          a3= 0.3279d+01+0.5066d+01*sb -0.9134d+01*sb2+0.2897d+01*sb3

          a4= 0.4399d+00-0.5888d+00*sb +0.4802d+00*sb2-0.1664d+00*sb3

          a5= 0.3678d+00-0.8929d+00*sb +0.1592d+01*sb2-0.5713d+00*sb3

        ELSEIF(iprt .EQ. 0) THEN

          a0=exp(-0.2318d+00-0.9779d+00*sb -0.3783d+00*sb2+

     &    0.1037d-01*sb3)

          a1=-0.2916d+00+0.1754d+00*sb -0.1884d+00*sb2+0.6116d-01*sb3

          a2= 0.5349d+01+0.7460d+00*sb +0.2319d+00*sb2-0.2622d+00*sb3

          a3= 0.6920d+01-0.3454d+01*sb +0.2027d+01*sb2-0.7626d+00*sb3

          a4= 0.1013d+01+0.1423d+00*sb -0.1798d+00*sb2+0.1872d-01*sb3

          a5=-0.5465d-01+0.2303d+01*sb -0.9584d+00*sb2+0.3098d+00*sb3

        ELSEIF(iprt .EQ. -1) THEN

          a0=exp(-0.2328d+01-0.3061d+01*sb +0.3620d+01*sb2-

     &    0.1602d+01*sb3)

          a1=-0.3358d+00+0.3198d+00*sb -0.4210d+00*sb2+0.1571d+00*sb3

          a2= 0.8478d+01-0.3112d+01*sb +0.5243d+01*sb2-0.2255d+01*sb3

          a3= 0.1971d+02+0.3389d+00*sb -0.5268d+01*sb2+0.2099d+01*sb3

          a4= 0.1128d+01-0.4701d+00*sb +0.7779d+00*sb2-0.3506d+00*sb3

          a5=-0.4708d+00+0.3341d+01*sb -0.3375d+01*sb2+0.1353d+01*sb3

        ELSEIF(iprt .EQ. -2) THEN

          a0=exp(-0.2906d+01-0.1069d+00*sb -0.1055d+01*sb2+

     &    0.2496d+00*sb3)

          a1=-0.2875d+00+0.6571d-01*sb -0.1987d-01*sb2-0.1800d-02*sb3

          a2= 0.9854d+01-0.2715d+00*sb -0.7407d+00*sb2+0.2888d+00*sb3

          a3= 0.1583d+02-0.7687d+01*sb +0.3428d+01*sb2-0.3327d+00*sb3

          a4= 0.9763d+00+0.7599d-01*sb -0.2128d+00*sb2+0.6852d-01*sb3

          a5=-0.8444d-02+0.9434d+00*sb +0.4152d+00*sb2-0.1481d+00*sb3

        ELSEIF(iprt .EQ. -3) THEN

          a0=exp(-0.3780d+01+0.2499d+01*sb -0.4962d+01*sb2+

     &    0.1936d+01*sb3)

          a1=-0.2639d+00-0.1575d+00*sb +0.3584d+00*sb2-0.1646d+00*sb3

          a2= 0.8082d+01+0.2794d+01*sb -0.5438d+01*sb2+0.2321d+01*sb3

          a3= 0.1811d+02-0.2000d+02*sb +0.1951d+02*sb2-0.6904d+01*sb3

          a4= 0.9822d+00+0.4972d+00*sb -0.8690d+00*sb2+0.3415d+00*sb3

          a5= 0.1772d+00-0.6078d+00*sb +0.3341d+01*sb2-0.1473d+01*sb3

        ELSEIF(iprt .EQ. -4) THEN

          a0=sb** 0.1122d+01*exp(-0.4232d+01-0.1808d+01*sb +

     &    0.5348d+00*sb2)

          a1=-0.2824d+00+0.5846d+00*sb -0.7230d+00*sb2+0.2419d+00*sb3

          a2= 0.5683d+01-0.2948d+01*sb +0.5916d+01*sb2-0.2560d+01*sb3

          a3= 0.2051d+01+0.4795d+01*sb -0.4271d+01*sb2+0.4174d+00*sb3

          a4= 0.1737d+00+0.1717d+01*sb -0.1978d+01*sb2+0.6643d+00*sb3

          a5= 0.8689d+00+0.3500d+01*sb -0.3283d+01*sb2+0.1026d+01*sb3

        ELSEIF(iprt .EQ. -5) THEN

          a0=sb** 0.9906d+00*exp(-0.1496d+01-0.6576d+01*sb +

     &    0.1569d+01*sb2)

          a1=-0.2140d+00-0.6419d-01*sb -0.2741d-02*sb2+0.3185d-02*sb3

          a2= 0.5781d+01+0.1049d+00*sb -0.3930d+00*sb2+0.5174d+00*sb3

          a3=-0.9420d+00+0.5511d+00*sb +0.8817d+00*sb2+0.1903d+01*sb3

          a4= 0.2418d-01+0.4232d-01*sb -0.1244d-01*sb2-0.2365d-01*sb3

          a5= 0.7664d+00+0.1794d+01*sb -0.4917d+00*sb2-0.1284d+00*sb3

        ELSEIF(iprt .EQ. -6) THEN

          a0=sb** 0.1000d+01*exp(-0.8460d+01+0.1154d+01*sb +

     &    0.8838d+01*sb2)

          a1=-0.4316d-01-0.2976d+00*sb +0.3174d+00*sb2-0.1429d+01*sb3

          a2= 0.4910d+01+0.2273d+01*sb +0.5631d+01*sb2-0.1994d+02*sb3

          a3= 0.1190d+02-0.2000d+02*sb -0.2000d+02*sb2+0.1292d+02*sb3

          a4= 0.5771d+00-0.2552d+00*sb +0.7510d+00*sb2+0.6923d+00*sb3

          a5= 0.4402d+01-0.1627d+01*sb -0.2085d+01*sb2-0.6737d+01*sb3

        ENDIF


C...Expansion for CTEQ3D.

      ELSEIF(iset .EQ. 3) THEN

        IF(iprt .EQ. 2) THEN

          a0=exp( 0.2148d+00+0.5814d-01*sb +0.2734d+00*sb2-

     &    0.2902d+00*sb3)

          a1= 0.4810d+00+0.1657d-01*sb -0.3800d-01*sb2+0.3125d-01*sb3

          a2= 0.3509d+01+0.3923d+00*sb +0.4010d+00*sb2-0.1932d+00*sb3

          a3= 0.7055d+01-0.6552d+01*sb +0.3466d+01*sb2-0.5657d+00*sb3

          a4= 0.1061d+01-0.3453d+00*sb +0.4089d+00*sb2-0.1817d+00*sb3

          a5= 0.8687d-01+0.2548d+00*sb -0.2967d+00*sb2+0.2647d+00*sb3

        ELSEIF(iprt .EQ. 1) THEN

          a0=exp( 0.3961d+00+0.4914d+00*sb -0.1728d+01*sb2+

     &    0.7257d+00*sb3)

          a1= 0.4162d+00-0.1419d+00*sb +0.3680d+00*sb2-0.1618d+00*sb3

          a2= 0.3248d+01+0.3028d+01*sb -0.4307d+01*sb2+0.1920d+01*sb3

          a3=-0.1100d+01+0.2184d+01*sb -0.3820d+01*sb2+0.1717d+01*sb3

          a4= 0.2082d+01-0.2756d+00*sb +0.3043d+00*sb2-0.1260d+00*sb3

          a5=-0.4822d+00-0.5706d+00*sb +0.2243d+01*sb2-0.9760d+00*sb3

        ELSEIF(iprt .EQ. 0) THEN

          a0=exp(-0.4665d+00-0.7554d+00*sb -0.3323d+00*sb2-

     &    0.2734d-04*sb3)

          a1=-0.3359d+00+0.2395d+00*sb -0.2377d+00*sb2+0.7059d-01*sb3

          a2= 0.5451d+01+0.6086d+00*sb +0.8606d-01*sb2-0.1425d+00*sb3

          a3= 0.1026d+02-0.9352d+01*sb +0.4879d+01*sb2-0.1150d+01*sb3

          a4= 0.9935d+00-0.5017d-01*sb -0.1707d-01*sb2-0.1464d-02*sb3

          a5=-0.4160d-01+0.2305d+01*sb -0.1063d+01*sb2+0.3211d+00*sb3

        ELSEIF(iprt .EQ. -1) THEN

          a0=exp(-0.2714d+01-0.2868d+01*sb +0.3700d+01*sb2-

     &    0.1671d+01*sb3)

          a1=-0.3893d+00+0.3341d+00*sb -0.3897d+00*sb2+0.1420d+00*sb3

          a2= 0.8359d+01-0.3267d+01*sb +0.5327d+01*sb2-0.2245d+01*sb3

          a3= 0.2359d+02-0.5669d+01*sb -0.4602d+01*sb2+0.3153d+01*sb3

          a4= 0.1106d+01-0.4745d+00*sb +0.7739d+00*sb2-0.3417d+00*sb3

          a5=-0.5557d+00+0.3433d+01*sb -0.3390d+01*sb2+0.1354d+01*sb3

        ELSEIF(iprt .EQ. -2) THEN

          a0=exp(-0.3323d+01+0.2296d+00*sb -0.1109d+01*sb2+

     &    0.2223d+00*sb3)

          a1=-0.3410d+00+0.8847d-01*sb -0.1111d-01*sb2-0.5927d-02*sb3

          a2= 0.9753d+01-0.5182d+00*sb -0.4670d+00*sb2+0.1921d+00*sb3

          a3= 0.1977d+02-0.1600d+02*sb +0.9481d+01*sb2-0.1864d+01*sb3

          a4= 0.9818d+00+0.2839d-02*sb -0.1188d+00*sb2+0.3584d-01*sb3

          a5=-0.7934d-01+0.1004d+01*sb +0.3704d+00*sb2-0.1220d+00*sb3

        ELSEIF(iprt .EQ. -3) THEN

          a0=exp(-0.3985d+01+0.2855d+01*sb -0.5208d+01*sb2+

     &    0.1937d+01*sb3)

          a1=-0.3337d+00-0.1150d+00*sb +0.3691d+00*sb2-0.1709d+00*sb3

          a2= 0.7968d+01+0.3641d+01*sb -0.6599d+01*sb2+0.2642d+01*sb3

          a3= 0.1873d+02-0.1999d+02*sb +0.1734d+02*sb2-0.5813d+01*sb3

          a4= 0.9731d+00+0.5082d+00*sb -0.8780d+00*sb2+0.3231d+00*sb3

          a5=-0.5542d-01-0.4189d+00*sb +0.3309d+01*sb2-0.1439d+01*sb3

        ELSEIF(iprt .EQ. -4) THEN

          a0=sb** 0.1105d+01*exp(-0.3952d+01-0.1901d+01*sb +

     &    0.5137d+00*sb2)

          a1=-0.3543d+00+0.6055d+00*sb -0.6941d+00*sb2+0.2278d+00*sb3

          a2= 0.5955d+01-0.2629d+01*sb +0.5337d+01*sb2-0.2300d+01*sb3

          a3= 0.1933d+01+0.4882d+01*sb -0.3810d+01*sb2+0.2290d+00*sb3

          a4= 0.1806d+00+0.1655d+01*sb -0.1893d+01*sb2+0.6395d+00*sb3

          a5= 0.4790d+00+0.3612d+01*sb -0.3152d+01*sb2+0.9684d+00*sb3

        ELSEIF(iprt .EQ. -5) THEN

          a0=sb** 0.9818d+00*exp(-0.1825d+01-0.7464d+01*sb +

     &    0.2143d+01*sb2)

          a1=-0.2604d+00-0.1400d+00*sb +0.1702d+00*sb2-0.8476d-01*sb3

          a2= 0.6005d+01+0.6275d+00*sb -0.2535d+01*sb2+0.2219d+01*sb3

          a3=-0.9067d+00+0.1149d+01*sb +0.1974d+01*sb2+0.4716d+01*sb3

          a4= 0.3915d-01+0.5945d-01*sb -0.9844d-01*sb2+0.2783d-01*sb3

          a5= 0.5500d+00+0.1994d+01*sb -0.6727d+00*sb2-0.1510d+00*sb3

        ELSEIF(iprt .EQ. -6) THEN

          a0=sb** 0.1002d+01*exp(-0.8553d+01+0.3793d+00*sb +

     &    0.9998d+01*sb2)

          a1=-0.5870d-01-0.2792d+00*sb +0.6526d+00*sb2-0.1984d+01*sb3

          a2= 0.4716d+01+0.4473d+00*sb +0.1128d+02*sb2-0.1937d+02*sb3

          a3= 0.1289d+02-0.1742d+02*sb -0.1983d+02*sb2-0.9274d+00*sb3

          a4= 0.5647d+00-0.2732d+00*sb +0.1074d+01*sb2+0.5981d+00*sb3

          a5= 0.4390d+01-0.1262d+01*sb -0.9026d+00*sb2-0.9394d+01*sb3

        ENDIF

      ENDIF


C...Calculation of x * f(x, Q).

      pycteq = max(0d0, a0 *(x**a1) *((1d0-x)**a2) *(1d0+a3*(x**a4))

     &   *(log(1d0+1d0/x))**a5 )


      RETURN

      END


C*********************************************************************


C...PYGRVL

C...Gives the GRV 94 L (leading order) parton distribution function set

C...in parametrized form.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      SUBROUTINE pygrvl (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Common expressions.

      mu2  = 0.23d0

      lam2 = 0.2322d0 * 0.2322d0

      s  = log(log(q2/lam2) / log(mu2/lam2))

      ds = sqrt(s)

      s2 = s * s

      s3 = s2 * s


C...uv :

      nu  =  2.284d0 + 0.802d0 * s + 0.055d0 * s2

      aku =  0.590d0 - 0.024d0 * s

      bku =  0.131d0 + 0.063d0 * s

      au  = -0.449d0 - 0.138d0 * s - 0.076d0 * s2

      bu  =  0.213d0 + 2.669d0 * s - 0.728d0 * s2

      cu  =  8.854d0 - 9.135d0 * s + 1.979d0 * s2

      du  =  2.997d0 + 0.753d0 * s - 0.076d0 * s2

      uv  = pygrvv(x, nu, aku, bku, au, bu, cu, du)


C...dv :

      nd  =  0.371d0 + 0.083d0 * s + 0.039d0 * s2

      akd =  0.376d0

      bkd =  0.486d0 + 0.062d0 * s

      ad  = -0.509d0 + 3.310d0 * s - 1.248d0 * s2

      bd  =  12.41d0 - 10.52d0 * s + 2.267d0 * s2

      cd  =  6.373d0 - 6.208d0 * s + 1.418d0 * s2

      dd  =  3.691d0 + 0.799d0 * s - 0.071d0 * s2

      dv  = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)


C...del :

      ne  =  0.082d0 + 0.014d0 * s + 0.008d0 * s2

      ake =  0.409d0 - 0.005d0 * s

      bke =  0.799d0 + 0.071d0 * s

      ae  = -38.07d0 + 36.13d0 * s - 0.656d0 * s2

      be  =  90.31d0 - 74.15d0 * s + 7.645d0 * s2

      ce  =  0.0d0

      de  =  7.486d0 + 1.217d0 * s - 0.159d0 * s2

      del = pygrvv(x, ne, ake, bke, ae, be, ce, de)


C...udb :

      alx =  1.451d0

      bex =  0.271d0

      akx =  0.410d0 - 0.232d0 * s

      bkx =  0.534d0 - 0.457d0 * s

      agx =  0.890d0 - 0.140d0 * s

      bgx = -0.981d0

      cx  =  0.320d0 + 0.683d0 * s

      dx  =  4.752d0 + 1.164d0 * s + 0.286d0 * s2

      ex  =  4.119d0 + 1.713d0 * s

      esx =  0.682d0 + 2.978d0 * s

      udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,

     & dx, ex, esx)


C...sb :

      sts =  0d0

      als =  0.914d0

      bes =  0.577d0

      aks =  1.798d0 - 0.596d0 * s

      as  = -5.548d0 + 3.669d0 * ds - 0.616d0 * s

      bs  =  18.92d0 - 16.73d0 * ds + 5.168d0 * s

      dst =  6.379d0 - 0.350d0 * s  + 0.142d0 * s2

      est =  3.981d0 + 1.638d0 * s

      ess =  6.402d0

      sb  = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)


C...cb :

      stc =  0.888d0

      alc =  1.01d0

      bec =  0.37d0

      akc =  0d0

      ac  =  0d0

      bc  =  4.24d0  - 0.804d0 * s

      dct =  3.46d0  - 1.076d0 * s

      ect =  4.61d0  + 1.49d0  * s

      esc =  2.555d0 + 1.961d0 * s

      chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)


C...bb :

      stb =  1.351d0

      alb =  1.00d0

      beb =  0.51d0

      akb =  0d0

      ab  =  0d0

      bb  =  1.848d0

      dbt =  2.929d0 + 1.396d0 * s

      ebt =  4.71d0  + 1.514d0 * s

      esb =  4.02d0  + 1.239d0 * s

      bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)


C...gl :

      alg =  0.524d0

      beg =  1.088d0

      akg =  1.742d0 - 0.930d0 * s

      bkg =                         - 0.399d0 * s2

      ag  =  7.486d0 - 2.185d0 * s

      bg  =  16.69d0 - 22.74d0 * s  + 5.779d0 * s2

      cg  = -25.59d0 + 29.71d0 * s  - 7.296d0 * s2

      dg  =  2.792d0 + 2.215d0 * s  + 0.422d0 * s2 - 0.104d0 * s3

      eg  =  0.807d0 + 2.005d0 * s

      esg =  3.841d0 + 0.316d0 * s

      gl  = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg,

     & dg, eg, esg)


      RETURN

      END


C*********************************************************************


C...PYGRVM

C...Gives the GRV 94 M (MSbar) parton distribution function set

C...in parametrized form.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      SUBROUTINE pygrvm (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Common expressions.

      mu2  = 0.34d0

      lam2 = 0.248d0 * 0.248d0

      s  = log(log(q2/lam2) / log(mu2/lam2))

      ds = sqrt(s)

      s2 = s * s

      s3 = s2 * s


C...uv :

      nu  =  1.304d0 + 0.863d0 * s

      aku =  0.558d0 - 0.020d0 * s

      bku =          0.183d0 * s

      au  = -0.113d0 + 0.283d0 * s - 0.321d0 * s2

      bu  =  6.843d0 - 5.089d0 * s + 2.647d0 * s2 - 0.527d0 * s3

      cu  =  7.771d0 - 10.09d0 * s + 2.630d0 * s2

      du  =  3.315d0 + 1.145d0 * s - 0.583d0 * s2 + 0.154d0 * s3

      uv  = pygrvv(x, nu, aku, bku, au, bu, cu, du)


C...dv :

      nd  =  0.102d0 - 0.017d0 * s + 0.005d0 * s2

      akd =  0.270d0 - 0.019d0 * s

      bkd =  0.260d0

      ad  =  2.393d0 + 6.228d0 * s - 0.881d0 * s2

      bd  =  46.06d0 + 4.673d0 * s - 14.98d0 * s2 + 1.331d0 * s3

      cd  =  17.83d0 - 53.47d0 * s + 21.24d0 * s2

      dd  =  4.081d0 + 0.976d0 * s - 0.485d0 * s2 + 0.152d0 * s3

      dv  = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)


C...del :

      ne  =  0.070d0 + 0.042d0 * s - 0.011d0 * s2 + 0.004d0 * s3

      ake =  0.409d0 - 0.007d0 * s

      bke =  0.782d0 + 0.082d0 * s

      ae  = -29.65d0 + 26.49d0 * s + 5.429d0 * s2

      be  =  90.20d0 - 74.97d0 * s + 4.526d0 * s2

      ce  =  0.0d0

      de  =  8.122d0 + 2.120d0 * s - 1.088d0 * s2 + 0.231d0 * s3

      del = pygrvv(x, ne, ake, bke, ae, be, ce, de)


C...udb :

      alx =  0.877d0

      bex =  0.561d0

      akx =  0.275d0

      bkx =  0.0d0

      agx =  0.997d0

      bgx =  3.210d0 - 1.866d0 * s

      cx  =  7.300d0

      dx  =  9.010d0 + 0.896d0 * ds + 0.222d0 * s2

      ex  =  3.077d0 + 1.446d0 * s

      esx =  3.173d0 - 2.445d0 * ds + 2.207d0 * s

      udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,

     & dx, ex, esx)


C...sb :

      sts =  0d0

      als =  0.756d0

      bes =  0.216d0

      aks =  1.690d0 + 0.650d0 * ds - 0.922d0 * s

      as  = -4.329d0 + 1.131d0 * s

      bs  =  9.568d0 - 1.744d0 * s

      dst =  9.377d0 + 1.088d0 * ds - 1.320d0 * s + 0.130d0 * s2

      est =  3.031d0 + 1.639d0 * s

      ess =  5.837d0 + 0.815d0 * s

      sb  = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)


C...cb :

      stc =  0.820d0

      alc =  0.98d0

      bec =  0d0

      akc = -0.625d0 - 0.523d0 * s

      ac  =  0d0

      bc  =  1.896d0 + 1.616d0 * s

      dct =  4.12d0  + 0.683d0 * s

      ect =  4.36d0  + 1.328d0 * s

      esc =  0.677d0 + 0.679d0 * s

      chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)


C...bb :

      stb =  1.297d0

      alb =  0.99d0

      beb =  0d0

      akb =          - 0.193d0 * s

      ab  =  0d0

      bb  =  0d0

      dbt =  3.447d0 + 0.927d0 * s

      ebt =  4.68d0  + 1.259d0 * s

      esb =  1.892d0 + 2.199d0 * s

      bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)


C...gl :

       alg =  1.014d0

       beg =  1.738d0

       akg =  1.724d0 + 0.157d0 * s

       bkg =  0.800d0 + 1.016d0 * s

       ag  =  7.517d0 - 2.547d0 * s

       bg  =  34.09d0 - 52.21d0 * ds + 17.47d0 * s

       cg  =  4.039d0 + 1.491d0 * s

       dg  =  3.404d0 + 0.830d0 * s

       eg  = -1.112d0 + 3.438d0 * s  - 0.302d0 * s2

       esg =  3.256d0 - 0.436d0 * s

       gl  = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)


       RETURN

       END


C*********************************************************************


C...PYGRVD

C...Gives the GRV 94 D (DIS) parton distribution function set

C...in parametrized form.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      SUBROUTINE pygrvd (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Common expressions.

      mu2  = 0.34d0

      lam2 = 0.248d0 * 0.248d0

      s  = log(log(q2/lam2) / log(mu2/lam2))

      ds = sqrt(s)

      s2 = s * s

      s3 = s2 * s


C...uv :

      nu  =  2.484d0 + 0.116d0 * s + 0.093d0 * s2

      aku =  0.563d0 - 0.025d0 * s

      bku =  0.054d0 + 0.154d0 * s

      au  = -0.326d0 - 0.058d0 * s - 0.135d0 * s2

      bu  = -3.322d0 + 8.259d0 * s - 3.119d0 * s2 + 0.291d0 * s3

      cu  =  11.52d0 - 12.99d0 * s + 3.161d0 * s2

      du  =  2.808d0 + 1.400d0 * s - 0.557d0 * s2 + 0.119d0 * s3

      uv  = pygrvv(x, nu, aku, bku, au, bu, cu, du)


C...dv :

      nd  =  0.156d0 - 0.017d0 * s

      akd =  0.299d0 - 0.022d0 * s

      bkd =  0.259d0 - 0.015d0 * s

      ad  =  3.445d0 + 1.278d0 * s + 0.326d0 * s2

      bd  = -6.934d0 + 37.45d0 * s - 18.95d0 * s2 + 1.463d0 * s3

      cd  =  55.45d0 - 69.92d0 * s + 20.78d0 * s2

      dd  =  3.577d0 + 1.441d0 * s - 0.683d0 * s2 + 0.179d0 * s3

      dv  = pygrvv(x, nd, akd, bkd, ad, bd, cd, dd)


C...del :

      ne  =  0.099d0 + 0.019d0 * s + 0.002d0 * s2

      ake =  0.419d0 - 0.013d0 * s

      bke =  1.064d0 - 0.038d0 * s

      ae  = -44.00d0 + 98.70d0 * s - 14.79d0 * s2

      be  =  28.59d0 - 40.94d0 * s - 13.66d0 * s2 + 2.523d0 * s3

      ce  =  84.57d0 - 108.8d0 * s + 31.52d0 * s2

      de  =  7.469d0 + 2.480d0 * s - 0.866d0 * s2

      del = pygrvv(x, ne, ake, bke, ae, be, ce, de)


C...udb :

      alx =  1.215d0

      bex =  0.466d0

      akx =  0.326d0 + 0.150d0 * s

      bkx =  0.956d0 + 0.405d0 * s

      agx =  0.272d0

      bgx =  3.794d0 - 2.359d0 * ds

      cx  =  2.014d0

      dx  =  7.941d0 + 0.534d0 * ds - 0.940d0 * s + 0.410d0 * s2

      ex  =  3.049d0 + 1.597d0 * s

      esx =  4.396d0 - 4.594d0 * ds + 3.268d0 * s

      udb = pygrvw(x, s, alx, bex, akx, bkx, agx, bgx, cx,

     & dx, ex, esx)


C...sb :

      sts =  0d0

      als =  0.175d0

      bes =  0.344d0

      aks =  1.415d0 - 0.641d0 * ds

      as  =  0.580d0 - 9.763d0 * ds + 6.795d0 * s  - 0.558d0 * s2

      bs  =  5.617d0 + 5.709d0 * ds - 3.972d0 * s

      dst =  13.78d0 - 9.581d0 * s  + 5.370d0 * s2 - 0.996d0 * s3

      est =  4.546d0 + 0.372d0 * s2

      ess =  5.053d0 - 1.070d0 * s  + 0.805d0 * s2

      sb  = pygrvs(x, s, sts, als, bes, aks, as, bs, dst, est, ess)


C...cb :

      stc =  0.820d0

      alc =  0.98d0

      bec =  0d0

      akc = -0.625d0 - 0.523d0 * s

      ac  =  0d0

      bc  =  1.896d0 + 1.616d0 * s

      dct =  4.12d0  + 0.683d0 * s

      ect =  4.36d0  + 1.328d0 * s

      esc =  0.677d0 + 0.679d0 * s

      chm = pygrvs(x, s, stc, alc, bec, akc, ac, bc, dct, ect, esc)


C...bb :

      stb =  1.297d0

      alb =  0.99d0

      beb =  0d0

      akb =          - 0.193d0 * s

      ab  =  0d0

      bb  =  0d0

      dbt =  3.447d0 + 0.927d0 * s

      ebt =  4.68d0  + 1.259d0 * s

      esb =  1.892d0 + 2.199d0 * s

      bot = pygrvs(x, s, stb, alb, beb, akb, ab, bb, dbt, ebt, esb)


C...gl :

      alg =  1.258d0

      beg =  1.846d0

      akg =  2.423d0

      bkg =  2.427d0 + 1.311d0 * s  - 0.153d0 * s2

      ag  =  25.09d0 - 7.935d0 * s

      bg  = -14.84d0 - 124.3d0 * ds + 72.18d0 * s

      cg  =  590.3d0 - 173.8d0 * s

      dg  =  5.196d0 + 1.857d0 * s

      eg  = -1.648d0 + 3.988d0 * s  - 0.432d0 * s2

      esg =  3.232d0 - 0.542d0 * s

      gl  = pygrvw(x, s, alg, beg, akg, bkg, ag, bg, cg, dg, eg, esg)


      RETURN

      END


C*********************************************************************


C...PYGRVV

C...Auxiliary for the GRV 94 parton distribution functions

C...for u and d valence and d-u sea.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      FUNCTION pygrvv (X, N, AK, BK, A, B, C, D)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Evaluation.

      dx = sqrt(x)

      pygrvv = n * x**ak * (1d0+ a*x**bk + x * (b + c*dx)) *

     & (1d0- x)**d


      RETURN

      END


C*********************************************************************


C...PYGRVW

C...Auxiliary for the GRV 94 parton distribution functions

C...for d+u sea and gluon.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      FUNCTION pygrvw (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Evaluation.

      lx = log(1d0/x)

      pygrvw = (x**ak * (a + x * (b + x*c)) * lx**bk + s**al

     &     * exp(-e + sqrt(es * s**be * lx))) * (1d0- x)**d


      RETURN

      END


C*********************************************************************


C...PYGRVS

C...Auxiliary for the GRV 94 parton distribution functions

C...for s, c and b sea.

C...Authors: M. Glueck, E. Reya and A. Vogt.


      FUNCTION pygrvs (X, S, STH, AL, BE, AK, AG, B, D, E, ES)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION (a - z)


C...Evaluation.

      IF(s.LE.sth) THEN

        pygrvs = 0d0

      ELSE

        dx = sqrt(x)

        lx = log(1d0/x)

        pygrvs = (s - sth)**al / lx**ak * (1d0+ ag*dx + b*x) *

     &     (1d0- x)**d * exp(-e + sqrt(es * s**be * lx))

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYHFTH

C...Gives threshold attractive/repulsive factor for heavy flavour

C...production.


      FUNCTION pyhfth(SH,SQM,FRATT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pydat1/,/pypars/,/pyint1/


C...Value for alpha_strong.

      IF(mstp(35).LE.1) THEN

        alssg=parp(35)

      ELSE

        mst115=mstu(115)

        mstu(115)=mstp(36)

        q2bn=sqrt(max(1d0,sqm*((sqrt(sh)-2d0*sqrt(sqm))**2+

     &  parp(36)**2)))

        alssg=pyalps(q2bn)

        mstu(115)=mst115

      ENDIF


C...Evaluate attractive and repulsive factors.

      xattr=4d0*paru(1)*alssg/(3d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))

      fattr=xattr/(1d0-exp(-min(50d0,xattr)))

      xrepu=paru(1)*alssg/(6d0*sqrt(max(1d-20,1d0-4d0*sqm/sh)))

      frepu=xrepu/(exp(min(50d0,xrepu))-1d0)

      pyhfth=fratt*fattr+(1d0-fratt)*frepu

      vint(138)=pyhfth


      RETURN

      END


C*********************************************************************


C...PYSPLI

C...Splits a hadron remnant into two (partons or hadron + parton)

C...in case it is more complicated than just a quark or a diquark.


      SUBROUTINE pyspli(KF,KFLIN,KFLCH,KFLSP)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      SAVE /pypars/,/pyint1/

C...Local array.

      dimension kfl(3)


C...Preliminaries. Parton composition.

      kfa=iabs(kf)

      kfs=isign(1,kf)

      kfl(1)=mod(kfa/1000,10)

      kfl(2)=mod(kfa/100,10)

      kfl(3)=mod(kfa/10,10)

      IF(kfa.EQ.22.AND.mint(109).EQ.2) THEN

        kfl(2)=int(1.5d0+pyr(0))

        IF(mint(105).EQ.333) kfl(2)=3

        IF(mint(105).EQ.443) kfl(2)=4

        kfl(3)=kfl(2)

      ELSEIF((kfa.EQ.111.OR.kfa.EQ.113).AND.pyr(0).GT.0.5d0) THEN

        kfl(2)=2

        kfl(3)=2

      ELSEIF(kfa.EQ.223.AND.pyr(0).GT.0.5d0) THEN

        kfl(2)=1

        kfl(3)=1

      ENDIF

      IF(kflin.NE.21.AND.kflin.NE.22.AND.kflin.NE.23) THEN

        kflr=kflin*kfs

      ELSE

        kflr=kflin

      ENDIF

      kflch=0


C...Subdivide lepton.

      IF(kfa.GE.11.AND.kfa.LE.18) THEN

        IF(kflr.EQ.kfa) THEN

          kflsp=kfs*22

        ELSEIF(kflr.EQ.22) THEN

          kflsp=kfa

        ELSEIF(kflr.EQ.-24.AND.mod(kfa,2).EQ.1) THEN

          kflsp=kfa+1

        ELSEIF(kflr.EQ.24.AND.mod(kfa,2).EQ.0) THEN

          kflsp=kfa-1

        ELSEIF(kflr.EQ.21) THEN

          kflsp=kfa

          kflch=kfs*21

        ELSE

          kflsp=kfa

          kflch=-kflr

        ENDIF


C...Subdivide photon.

      ELSEIF(kfa.EQ.22.AND.mint(109).NE.2) THEN

        IF(kflr.NE.21) THEN

          kflsp=-kflr

        ELSE

          ragr=0.75d0*pyr(0)

          kflsp=1

          IF(ragr.GT.0.125d0) kflsp=2

          IF(ragr.GT.0.625d0) kflsp=3

          IF(pyr(0).GT.0.5d0) kflsp=-kflsp

          kflch=-kflsp

        ENDIF


C...Subdivide Reggeon or Pomeron.

      ELSEIF(kfa.EQ.28.OR.kfa.EQ.29) THEN

        IF(kflin.EQ.21) THEN

          kflsp=kfs*21

        ELSE

          kflsp=-kflin

        ENDIF


C...Subdivide meson.

      ELSEIF(kfl(1).EQ.0) THEN

        kfl(2)=kfl(2)*(-1)**kfl(2)

        kfl(3)=-kfl(3)*(-1)**iabs(kfl(2))

        IF(kflr.EQ.kfl(2)) THEN

          kflsp=kfl(3)

        ELSEIF(kflr.EQ.kfl(3)) THEN

          kflsp=kfl(2)

        ELSEIF(kflr.EQ.21.AND.pyr(0).GT.0.5d0) THEN

          kflsp=kfl(2)

          kflch=kfl(3)

        ELSEIF(kflr.EQ.21) THEN

          kflsp=kfl(3)

          kflch=kfl(2)

        ELSEIF(kflr*kfl(2).GT.0) THEN

          CALL pykfdi(-kflr,kfl(2),kfdump,kflch)

          kflsp=kfl(3)

        ELSE

          CALL pykfdi(-kflr,kfl(3),kfdump,kflch)

          kflsp=kfl(2)

        ENDIF


C...Subdivide baryon.

      ELSE

        nagr=0

        DO 100 j=1,3

          IF(kflr.EQ.kfl(j)) nagr=nagr+1

  100   CONTINUE

        IF(nagr.GE.1) THEN

          ragr=0.00001d0+(nagr-0.00002d0)*pyr(0)

          iagr=0

          DO 110 j=1,3

            IF(kflr.EQ.kfl(j)) ragr=ragr-1d0

            IF(iagr.EQ.0.AND.ragr.LE.0d0) iagr=j

  110     CONTINUE

        ELSE

          iagr=1.00001d0+2.99998d0*pyr(0)

        ENDIF

        id1=1

        IF(iagr.EQ.1) id1=2

        IF(iagr.EQ.1.AND.kfl(3).GT.kfl(2)) id1=3

        id2=6-iagr-id1

        ksp=3

        IF(mod(kfa,10).EQ.2.AND.kfl(1).EQ.kfl(2)) THEN

          IF(iagr.NE.3.AND.pyr(0).GT.0.25d0) ksp=1

        ELSEIF(mod(kfa,10).EQ.2.AND.kfl(2).GE.kfl(3)) THEN

          IF(iagr.NE.1.AND.pyr(0).GT.0.25d0) ksp=1

        ELSEIF(mod(kfa,10).EQ.2) THEN

          IF(iagr.EQ.1) ksp=1

          IF(iagr.NE.1.AND.pyr(0).GT.0.75d0) ksp=1

        ENDIF

        kflsp=1000*kfl(id1)+100*kfl(id2)+ksp

        IF(kflr.EQ.21) THEN

          kflch=kfl(iagr)

        ELSEIF(nagr.EQ.0.AND.kflr.GT.0) THEN

          CALL pykfdi(-kflr,kfl(iagr),kfdump,kflch)

        ELSEIF(nagr.EQ.0) THEN

          CALL pykfdi(10000+kflsp,-kflr,kfdump,kflch)

          kflsp=kfl(iagr)

        ENDIF

      ENDIF


C...Add on correct sign for result.

      kflch=kflch*kfs

      kflsp=kflsp*kfs


      RETURN

      END


C*********************************************************************


C...PYGAMM

C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;

C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions

C...(Dover, 1965) 6.1.36.


      FUNCTION pygamm(X)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Local array and data.

      dimension b(8)

      DATA b/-0.577191652d0,0.988205891d0,-0.897056937d0,0.918206857d0,

     &-0.756704078d0,0.482199394d0,-0.193527818d0,0.035868343d0/


      nx=int(x)

      dx=x-nx


      pygamm=1d0

      dxp=1d0

      DO 100 i=1,8

        dxp=dxp*dx

        pygamm=pygamm+b(i)*dxp

  100 CONTINUE

      IF(x.LT.1d0) THEN

        pygamm=pygamm/x

      ELSE

        DO 110 ix=1,nx-1

          pygamm=(x-ix)*pygamm

  110   CONTINUE

      ENDIF


      RETURN

      END


C***********************************************************************


C...PYWAUX

C...Calculates real and imaginary parts of the auxiliary functions W1

C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van

C...der Bij, Nucl. Phys. B297 (1988) 221.


      SUBROUTINE pywaux(IAUX,EPS,WRE,WIM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


      asinh(x)=log(x+sqrt(x**2+1d0))

      acosh(x)=log(x+sqrt(x**2-1d0))


      IF(eps.LT.0d0) THEN

        IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*asinh(sqrt(-1d0/eps))

        IF(iaux.EQ.2) wre=4d0*(asinh(sqrt(-1d0/eps)))**2

        wim=0d0

      ELSEIF(eps.LT.1d0) THEN

        IF(iaux.EQ.1) wre=2d0*sqrt(1d0-eps)*acosh(sqrt(1d0/eps))

        IF(iaux.EQ.2) wre=4d0*(acosh(sqrt(1d0/eps)))**2-paru(1)**2

        IF(iaux.EQ.1) wim=-paru(1)*sqrt(1d0-eps)

        IF(iaux.EQ.2) wim=-4d0*paru(1)*acosh(sqrt(1d0/eps))

      ELSE

        IF(iaux.EQ.1) wre=2d0*sqrt(eps-1d0)*asin(sqrt(1d0/eps))

        IF(iaux.EQ.2) wre=-4d0*(asin(sqrt(1d0/eps)))**2

        wim=0d0

      ENDIF


      RETURN

      END


C***********************************************************************


C...PYI3AU

C...Calculates real and imaginary parts of the auxiliary function I3;

C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,

C...Nucl. Phys. B297 (1988) 221.


      SUBROUTINE pyi3au(EPS,RAT,Y3RE,Y3IM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


      be=0.5d0*(1d0+sqrt(1d0+rat*eps))

      IF(eps.LT.1d0) ga=0.5d0*(1d0+sqrt(1d0-eps))


      IF(eps.LT.0d0) THEN

        IF(abs(eps).LT.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN

          f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-

     &    pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+

     &    pyspen(0.25d0*(rat+1d0)*eps/(1d0+0.25d0*rat*eps),0d0,1)-

     &    pyspen((rat+1d0)/rat,0d0,1)+0.5d0*(log(1d0+0.25d0*rat*eps)**2-

     &    log(0.25d0*rat*eps)**2)+log(1d0-0.25d0*eps)*

     &    log((1d0+0.25d0*(rat-1d0)*eps)/(1d0+0.25d0*rat*eps))+

     &    log(-0.25d0*eps)*log(0.25d0*rat*eps/(1d0+0.25d0*(rat-1d0)*

     &    eps))

        ELSEIF(abs(eps).LT.1.d-4.AND.abs(rat*eps).GE.1.d-4) THEN

          f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-

     &    pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+

     &    pyspen((be-1d0+0.25d0*eps)/be,0d0,1)-

     &    pyspen((be-1d0+0.25d0*eps)/(be-1d0),0d0,1)+

     &    0.5d0*(log(be)**2-log(be-1d0)**2)+

     &    log(1d0-0.25d0*eps)*log((be-0.25d0*eps)/be)+

     &    log(-0.25d0*eps)*log((be-1d0)/(be-0.25d0*eps))

        ELSEIF(abs(eps).GE.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN

          f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-

     &    pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+

     &    pyspen((1d0+0.25d0*rat*eps-ga)/(1d0+0.25d0*rat*eps),0d0,1)-

     &    pyspen((1d0+0.25d0*rat*eps-ga)/(0.25d0*rat*eps),0d0,1)+

     &    0.5d0*(log(1d0+0.25d0*rat*eps)**2-log(0.25d0*rat*eps)**2)+

     &    log(ga)*log((ga+0.25d0*rat*eps)/(1d0+0.25d0*rat*eps))+

     &    log(ga-1d0)*log(0.25d0*rat*eps/(ga+0.25d0*rat*eps))

        ELSE

          f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-

     &    pyspen(ga/(ga+be-1d0),0d0,1)+pyspen((be-ga)/be,0d0,1)-

     &    pyspen((be-ga)/(be-1d0),0d0,1)+0.5d0*(log(be)**2-

     &    log(be-1d0)**2)+log(ga)*log((ga+be-1d0)/be)+

     &    log(ga-1d0)*log((be-1d0)/(ga+be-1d0))

        ENDIF

        f3im=0d0

      ELSEIF(eps.LT.1d0) THEN

        IF(abs(eps).LT.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN

          f3re=pyspen(-0.25d0*eps/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)-

     &    pyspen((1d0-0.25d0*eps)/(1d0+0.25d0*(rat-1d0)*eps),0d0,1)+

     &    pyspen((1d0-0.25d0*eps)/(-0.25d0*(rat+1d0)*eps),0d0,1)-

     &    pyspen(1d0/(rat+1d0),0d0,1)+log((1d0-0.25d0*eps)/

     &    (0.25d0*eps))*log((1d0+0.25d0*(rat-1d0)*eps)/

     &    (0.25d0*(rat+1d0)*eps))

          f3im=-paru(1)*log((1d0+0.25d0*(rat-1d0)*eps)/

     &    (0.25d0*(rat+1d0)*eps))

        ELSEIF(abs(eps).LT.1.d-4.AND.abs(rat*eps).GE.1.d-4) THEN

          f3re=pyspen(-0.25d0*eps/(be-0.25d0*eps),0d0,1)-

     &    pyspen((1d0-0.25d0*eps)/(be-0.25d0*eps),0d0,1)+

     &    pyspen((1d0-0.25d0*eps)/(1d0-0.25d0*eps-be),0d0,1)-

     &    pyspen(-0.25d0*eps/(1d0-0.25d0*eps-be),0d0,1)+

     &    log((1d0-0.25d0*eps)/(0.25d0*eps))*

     &    log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))

          f3im=-paru(1)*log((be-0.25d0*eps)/(be-1d0+0.25d0*eps))

        ELSEIF(abs(eps).GE.1.d-4.AND.abs(rat*eps).LT.1.d-4) THEN

          f3re=pyspen((ga-1d0)/(ga+0.25d0*rat*eps),0d0,1)-

     &    pyspen(ga/(ga+0.25d0*rat*eps),0d0,1)+

     &    pyspen(ga/(ga-1d0-0.25d0*rat*eps),0d0,1)-

     &    pyspen((ga-1d0)/(ga-1d0-0.25d0*rat*eps),0d0,1)+

     &    log(ga/(1d0-ga))*log((ga+0.25d0*rat*eps)/

     &    (1d0+0.25d0*rat*eps-ga))

          f3im=-paru(1)*log((ga+0.25d0*rat*eps)/

     &    (1d0+0.25d0*rat*eps-ga))

        ELSE

          f3re=pyspen((ga-1d0)/(ga+be-1d0),0d0,1)-

     &    pyspen(ga/(ga+be-1d0),0d0,1)+pyspen(ga/(ga-be),0d0,1)-

     &    pyspen((ga-1d0)/(ga-be),0d0,1)+log(ga/(1d0-ga))*

     &    log((ga+be-1d0)/(be-ga))

          f3im=-paru(1)*log((ga+be-1d0)/(be-ga))

        ENDIF

      ELSE

        rsq=eps/(eps-1d0+(2d0*be-1d0)**2)

        rcthe=rsq*(1d0-2d0*be/eps)

        rsthe=sqrt(max(0d0,rsq-rcthe**2))

        rcphi=rsq*(1d0+2d0*(be-1d0)/eps)

        rsphi=sqrt(max(0d0,rsq-rcphi**2))

        r=sqrt(rsq)

        the=acos(max(-0.999999d0,min(0.999999d0,rcthe/r)))

        phi=acos(max(-0.999999d0,min(0.999999d0,rcphi/r)))

        f3re=pyspen(rcthe,rsthe,1)+pyspen(rcthe,-rsthe,1)-

     &  pyspen(rcphi,rsphi,1)-pyspen(rcphi,-rsphi,1)+

     &  (phi-the)*(phi+the-paru(1))

        f3im=pyspen(rcthe,rsthe,2)+pyspen(rcthe,-rsthe,2)-

     &  pyspen(rcphi,rsphi,2)-pyspen(rcphi,-rsphi,2)

      ENDIF


      y3re=2d0/(2d0*be-1d0)*f3re

      y3im=2d0/(2d0*be-1d0)*f3im


      RETURN

      END


C***********************************************************************


C...PYSPEN

C...Calculates real and imaginary part of Spence function; see

C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.


      FUNCTION pyspen(XREIN,XIMIN,IREIM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local array and data.

      dimension b(0:14)

      DATA b/

     &1.000000d+00,        -5.000000d-01,         1.666667d-01,

     &0.000000d+00,        -3.333333d-02,         0.000000d+00,

     &2.380952d-02,         0.000000d+00,        -3.333333d-02,

     &0.000000d+00,         7.575757d-02,         0.000000d+00,

     &-2.531135d-01,         0.000000d+00,         1.166667d+00/


      xre=xrein

      xim=ximin

      IF(abs(1d0-xre).LT.1.d-6.AND.abs(xim).LT.1.d-6) THEN

        IF(ireim.EQ.1) pyspen=paru(1)**2/6d0

        IF(ireim.EQ.2) pyspen=0d0

        RETURN

      ENDIF


      xmod=sqrt(xre**2+xim**2)

      IF(xmod.LT.1.d-6) THEN

        IF(ireim.EQ.1) pyspen=0d0

        IF(ireim.EQ.2) pyspen=0d0

        RETURN

      ENDIF


      xarg=sign(acos(xre/xmod),xim)

      sp0re=0d0

      sp0im=0d0

      sgn=1d0

      IF(xmod.GT.1d0) THEN

        algxre=log(xmod)

        algxim=xarg-sign(paru(1),xarg)

        sp0re=-paru(1)**2/6d0-(algxre**2-algxim**2)/2d0

        sp0im=-algxre*algxim

        sgn=-1d0

        xmod=1d0/xmod

        xarg=-xarg

        xre=xmod*cos(xarg)

        xim=xmod*sin(xarg)

      ENDIF

      IF(xre.GT.0.5d0) THEN

        algxre=log(xmod)

        algxim=xarg

        xre=1d0-xre

        xim=-xim

        xmod=sqrt(xre**2+xim**2)

        xarg=sign(acos(xre/xmod),xim)

        algyre=log(xmod)

        algyim=xarg

        sp0re=sp0re+sgn*(paru(1)**2/6d0-(algxre*algyre-algxim*algyim))

        sp0im=sp0im-sgn*(algxre*algyim+algxim*algyre)

        sgn=-sgn

      ENDIF


      xre=1d0-xre

      xim=-xim

      xmod=sqrt(xre**2+xim**2)

      xarg=sign(acos(xre/xmod),xim)

      zre=-log(xmod)

      zim=-xarg


      spre=0d0

      spim=0d0

      savere=1d0

      saveim=0d0

      DO 100 i=0,14

        IF(max(abs(savere),abs(saveim)).LT.1d-30) goto 110

        termre=(savere*zre-saveim*zim)/dble(i+1)

        termim=(savere*zim+saveim*zre)/dble(i+1)

        savere=termre

        saveim=termim

        spre=spre+b(i)*termre

        spim=spim+b(i)*termim

  100 CONTINUE


  110 IF(ireim.EQ.1) pyspen=sp0re+sgn*spre

      IF(ireim.EQ.2) pyspen=sp0im+sgn*spim


      RETURN

      END


C***********************************************************************


C...PYQQBH

C...Calculates the matrix element for the processes

C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).

C...REDUCE output and part of the rest courtesy Z. Kunszt, see

C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.


      SUBROUTINE pyqqbh(WTQQBH)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pydat1/,/pydat2/,/pypars/,/pyint1/,/pyint2/

C...Local arrays and function.

      dimension pp(15,4),clr(8,8),fm(10,10),rm(8,8),dx(8)

      dot(i,j)=pp(i,4)*pp(j,4)-pp(i,1)*pp(j,1)-pp(i,2)*pp(j,2)-

     &pp(i,3)*pp(j,3)


C...Mass parameters.

      wtqqbh=0d0

      isub=mint(1)

      shpr=sqrt(vint(26))*vint(1)

      pq=pmas(pycomp(kfpr(isub,2)),1)

      ph=sqrt(vint(21))*vint(1)

      spq=pq**2

      sph=ph**2


C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.

      DO 100 i=1,2

        pt=sqrt(max(0d0,vint(197+5*i)))

        pp(i,1)=pt*cos(vint(198+5*i))

        pp(i,2)=pt*sin(vint(198+5*i))

  100 CONTINUE

      pp(3,1)=-pp(1,1)-pp(2,1)

      pp(3,2)=-pp(1,2)-pp(2,2)

      pms1=spq+pp(1,1)**2+pp(1,2)**2

      pms2=spq+pp(2,1)**2+pp(2,2)**2

      pms3=sph+pp(3,1)**2+pp(3,2)**2

      pmt3=sqrt(pms3)

      pp(3,3)=pmt3*sinh(vint(211))

      pp(3,4)=pmt3*cosh(vint(211))

      pms12=(shpr-pp(3,4))**2-pp(3,3)**2

      pp(1,3)=(-pp(3,3)*(pms12+pms1-pms2)+

     &vint(213)*(shpr-pp(3,4))*vint(220))/(2d0*pms12)

      pp(2,3)=-pp(1,3)-pp(3,3)

      pp(1,4)=sqrt(pms1+pp(1,3)**2)

      pp(2,4)=sqrt(pms2+pp(2,3)**2)


C...Set up incoming kinematics and derived momentum combinations.

      DO 110 i=4,5

        pp(i,1)=0d0

        pp(i,2)=0d0

        pp(i,3)=-0.5d0*shpr*(-1)**i

        pp(i,4)=-0.5d0*shpr

  110 CONTINUE

      DO 120 j=1,4

        pp(6,j)=pp(1,j)+pp(2,j)

        pp(7,j)=pp(1,j)+pp(3,j)

        pp(8,j)=pp(1,j)+pp(4,j)

        pp(9,j)=pp(1,j)+pp(5,j)

        pp(10,j)=-pp(2,j)-pp(3,j)

        pp(11,j)=-pp(2,j)-pp(4,j)

        pp(12,j)=-pp(2,j)-pp(5,j)

        pp(13,j)=-pp(4,j)-pp(5,j)

  120 CONTINUE


C...Derived kinematics invariants.

      x1=dot(1,2)

      x2=dot(1,3)

      x3=dot(1,4)

      x4=dot(1,5)

      x5=dot(2,3)

      x6=dot(2,4)

      x7=dot(2,5)

      x8=dot(3,4)

      x9=dot(3,5)

      x10=dot(4,5)


C...Propagators.

      ss1=dot(7,7)-spq

      ss2=dot(8,8)-spq

      ss3=dot(9,9)-spq

      ss4=dot(10,10)-spq

      ss5=dot(11,11)-spq

      ss6=dot(12,12)-spq

      ss7=dot(13,13)

      dx(1)=ss1*ss6

      dx(2)=ss2*ss6

      dx(3)=ss2*ss4

      dx(4)=ss1*ss5

      dx(5)=ss3*ss5

      dx(6)=ss3*ss4

      dx(7)=ss7*ss1

      dx(8)=ss7*ss4


C...Define colour coefficients for g + g -> Q + Qbar + H.

      IF(isub.EQ.121.OR.isub.EQ.181.OR.isub.EQ.186) THEN

        DO 140 i=1,3

          DO 130 j=1,3

            clr(i,j)=16d0/3d0

            clr(i+3,j+3)=16d0/3d0

            clr(i,j+3)=-2d0/3d0

            clr(i+3,j)=-2d0/3d0

  130     CONTINUE

  140   CONTINUE

        DO 160 l=1,2

          DO 150 i=1,3

            clr(i,6+l)=-6d0

            clr(i+3,6+l)=6d0

            clr(6+l,i)=-6d0

            clr(6+l,i+3)=6d0

  150     CONTINUE

  160   CONTINUE

        DO 180 k1=1,2

          DO 170 k2=1,2

            clr(6+k1,6+k2)=12d0

  170     CONTINUE

  180   CONTINUE


C...Evaluate matrix elements for g + g -> Q + Qbar + H.

        fm(1,1)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x4+x9+2*

     &  x7+x5)+8*pq**2*ph**2*(-x1-x4+2*x7)+16*pq**2*(x2*x9+4*x2*

     &  x7+x2*x5-2*x4*x7-2*x9*x7)+8*ph**2*x4*x7-16*x2*x9*x7

        fm(1,2)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10+x9-x8+2

     &  *x7-4*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x4-2*x2*x10+x2*x7-2*

     &  x2*x6-2*x3*x7+2*x4*x7+4*x10*x7-x9*x7-x8*x7)+16*x2*x7*(x4+

     &  x10)

        fm(1,3)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-2*x3-4*

     &  x4-8*x10+x9+x8-2*x7-4*x6+2*x5)-(4*pq**2*ph**2)*(x1+x4+x10

     &  +x6)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2

     &  -4*x2*x4-5*x2*x10+x2*x8-x2*x7-3*x2*x6+x2*x5+x3*x9+2*x3*x7

     &  -x3*x5+x4*x8+2*x4*x6-3*x4*x5-5*x10*x5+x9*x8+x9*x6+x9*x5+

     &  x8*x7-4*x6*x5+x5**2)-(16*x2*x5)*(x1+x4+x10+x6)

        fm(1,4)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1+x2-x3-x4+x10-

     &  x9-x8+2*x7+2*x6-x5)+4*pq**2*ph**2*(x1+x3+x4+x10+2*x7+2*x6

     &  )+8*pq**2*(4*x1*x10+4*x1*x7+4*x1*x6+2*x2*x10-x2*x9-x2*x8+

     &  4*x2*x7+4*x2*x6-x2*x5+4*x10*x5+4*x7*x5+4*x6*x5)-(8*ph**2*

     &  x1)*(x10+x7+x6)+16*x2*x5*(x10+x7+x6)

        fm(1,5)=8*pq**4*(-2*x1-2*x4+x10-x9)+4*pq**2*(4*x1**2-2*x1*

     &  x2+8*x1*x3+6*x1*x10-2*x1*x9+4*x1*x8+4*x1*x7+4*x1*x6+2*x1*

     &  x5+x2*x10+4*x3*x4-x3*x9+2*x3*x7+3*x4*x8-2*x4*x6+2*x4*x5-4

     &  *x10*x7+3*x10*x5-3*x9*x6+3*x8*x7-4*x7**2+4*x7*x5)+8*(x1**

     &  2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5-x1*x4*

     &  x8-x1*x4*x5+x1*x10*x9+x1*x9*x7+x1*x9*x6-x1*x8*x7-x2*x3*x7

     &  +x2*x4*x6-x2*x10*x7-x2*x7**2+x3*x7*x5-x4*x10*x5-x4*x7*x5-

     &  x4*x6*x5)

        fm(1,6)=16*pq**4*(-4*x1-x4+x9-x7)+4*pq**2*ph**2*(-2*x1-x4-

     &  x7)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x4-3*x1*x9-2*x1*x7-3*

     &  x1*x5-2*x2*x4-2*x7*x5)-8*ph**2*x4*x7+8*(-x1*x2*x9-2*x1*x2

     &  *x5-x1*x9**2-x1*x9*x5+x2**2*x7-x2*x4*x5+x2*x9*x7-x2*x7*x5

     &  +x4*x9*x5+x4*x5**2)

        fm(1,7)=8*pq**4*(2*x3+x4+3*x10+x9+2*x8+3*x7+6*x6)+2*pq**2*

     &  ph**2*(-2*x3-x4+3*x10+3*x7+6*x6)+4*pq**2*(4*x1*x10+4*x1*

     &  x7+8*x1*x6+6*x2*x10+x2*x9+2*x2*x8+6*x2*x7+12*x2*x6-8*x3*

     &  x7+4*x4*x7+4*x4*x6+4*x10*x5+4*x9*x7+4*x9*x6-8*x8*x7+4*x7*

     &  x5+8*x6*x5)+4*ph**2*(-x1*x10-x1*x7-2*x1*x6+2*x3*x7-x4*x7-

     &  x4*x6)+8*x2*(x10*x5+x9*x7+x9*x6-2*x8*x7+x7*x5+2*x6*x5)

        fm(1,8)=8*pq**4*(2*x3+x4+3*x10+2*x9+x8+3*x7+6*x6)+2*pq**2*

     &  ph**2*(-2*x3-x4+2*x10+x7+2*x6)+4*pq**2*(4*x1*x10-2*x1*x9+

     &  2*x1*x8+4*x1*x7+8*x1*x6+5*x2*x10+2*x2*x9+x2*x8+4*x2*x7+8*

     &  x2*x6-x3*x9-8*x3*x7+2*x3*x5+2*x4*x9-x4*x8+4*x4*x7+4*x4*x6

     &  +4*x4*x5+5*x10*x5+x9**2-x9*x8+2*x9*x7+5*x9*x6+x9*x5-7*x8*

     &  x7+2*x8*x5+2*x7*x5+10*x6*x5)+2*ph**2*(-x1*x10+x3*x7-2*x4*

     &  x7+x4*x6)+4*(-x1*x9**2+x1*x9*x8-2*x1*x9*x5-x1*x8*x5+2*x2*

     &  x10*x5+x2*x9*x7+x2*x9*x6-2*x2*x8*x7+3*x2*x6*x5+x3*x9*x5+

     &  x3*x5**2+x4*x9*x5-2*x4*x8*x5+2*x4*x5**2)

        fm(2,2)=16*pq**6+16*pq**4*(-x1+x3-x4-x10+x7-x6)+16*pq**2*(

     &  x3*x10+x3*x7+x3*x6+x4*x7+x10*x7)-16*x3*x10*x7

        fm(2,3)=16*pq**6+8*pq**4*(-2*x1+x2+2*x3-4*x4-4*x10-x9+x8-2

     &  *x7-2*x6+x5)+8*pq**2*(-2*x1*x5+4*x3*x10-x3*x9-x3*x8-2*x3*

     &  x7+2*x3*x6+x3*x5-2*x4*x5-2*x10*x5-2*x6*x5)+16*x3*x5*(x10+

     &  x6)

        fm(2,4)=8*pq**4*(-2*x1-2*x3+x10-x8)+4*pq**2*(4*x1**2-2*x1*

     &  x2+8*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+4*x1*x7+4*x1*x6+2*x1*

     &  x5+x2*x10+4*x3*x4+3*x3*x9-2*x3*x7+2*x3*x5-x4*x8+2*x4*x6-4

     &  *x10*x6+3*x10*x5+3*x9*x6-3*x8*x7-4*x6**2+4*x6*x5)+8*(-x1

     &  **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9-x1*x3*x5+x1*x4

     &  *x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x1*x8*x6+x2*x3*

     &  x7-x2*x4*x6-x2*x10*x6-x2*x6**2-x3*x10*x5-x3*x7*x5-x3*x6*

     &  x5+x4*x6*x5)

        fm(2,5)=16*pq**4*x10+8*pq**2*(2*x1**2+2*x1*x3+2*x1*x4+2*x1

     &  *x10+2*x1*x7+2*x1*x6+x3*x7+x4*x6)+8*(-2*x1**3-2*x1**2*x3-

     &  2*x1**2*x4-2*x1**2*x10-2*x1**2*x7-2*x1**2*x6-2*x1*x3*x4-

     &  x1*x3*x10-2*x1*x3*x6-x1*x4*x10-2*x1*x4*x7-x1*x10**2-x1*

     &  x10*x7-x1*x10*x6-2*x1*x7*x6+x3**2*x7-x3*x4*x7-x3*x4*x6+x3

     &  *x10*x7+x3*x7**2-x3*x7*x6+x4**2*x6+x4*x10*x6-x4*x7*x6+x4*

     &  x6**2)

        fm(2,6)=8*pq**4*(-2*x1+x10-x9-2*x7)+4*pq**2*(4*x1**2+2*x1*

     &  x2+4*x1*x3+4*x1*x4+6*x1*x10-2*x1*x9+4*x1*x8+8*x1*x6-2*x1*

     &  x5+4*x2*x4+3*x2*x10+2*x2*x7-3*x3*x9-2*x3*x7-4*x4**2-4*x4*

     &  x10+3*x4*x8+2*x4*x6+x10*x5-x9*x6+3*x8*x7+4*x7*x6)+8*(x1**

     &  2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9+x1*x3*x5+x1*x4*

     &  x9-x1*x4*x8-x1*x4*x5+x1*x10*x9+x1*x9*x6-x1*x8*x7-x2*x3*x7

     &  -x2*x4*x7+x2*x4*x6-x2*x10*x7+x3*x7*x5-x4**2*x5-x4*x10*x5-

     &  x4*x6*x5)

        fm(2,7)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-

     &  2*x1*x4-2*x1*x10+x1*x9-x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*

     &  x4+3*x2*x10+x2*x7+2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9-2*x3*

     &  x7-4*x3*x6-x3*x5-6*x4**2-6*x4*x10-3*x4*x9-x4*x8-4*x4*x7-2

     &  *x4*x6-2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+x10*x5

     &  +x9*x7-2*x8*x7-2*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(

     &  -x1**2*x9+x1**2*x8-2*x1*x2*x10-3*x1*x2*x7-3*x1*x2*x6+x1*

     &  x3*x9-x1*x3*x5+x1*x4*x9+x1*x4*x8+x1*x4*x5+x1*x10*x9+x1*

     &  x10*x8-x1*x9*x6+x1*x8*x6+x2*x3*x7-3*x2*x4*x7-x2*x4*x6-3*

     &  x2*x10*x7-3*x2*x10*x6-3*x2*x7*x6-3*x2*x6**2-2*x3*x4*x5-x3

     &  *x10*x5-x3*x6*x5-x4**2*x5-x4*x10*x5+x4*x6*x5)

        fm(2,8)=8*pq**4*(x3+2*x4+3*x10+x7+2*x6)+4*pq**2*(-4*x1*x3-

     &  2*x1*x4-2*x1*x10-x1*x9+x1*x8-4*x1*x7-2*x1*x6+x2*x3+2*x2*

     &  x4+x2*x10-x2*x7-2*x2*x6-6*x3*x4-6*x3*x10-2*x3*x9+x3*x8-2*

     &  x3*x7-4*x3*x6+x3*x5-6*x4**2-6*x4*x10-2*x4*x9-4*x4*x7-2*x4

     &  *x6+2*x4*x5-3*x10*x9-3*x10*x8-6*x10*x7-6*x10*x6+3*x10*x5-

     &  x9*x6-2*x8*x7-3*x8*x6-6*x7*x6+x7*x5-6*x6**2+2*x6*x5)+4*(

     &  x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6-3*x1*x3*x5+x1*x4*x9-

     &  x1*x4*x8-3*x1*x4*x5+x1*x10*x9+x1*x10*x8-2*x1*x10*x5+x1*x9

     &  *x6+x1*x8*x7+x1*x8*x6-x2*x4*x7+x2*x4*x6-x2*x10*x7-x2*x10*

     &  x6-2*x2*x7*x6-x2*x6**2-3*x3*x4*x5-3*x3*x10*x5+x3*x7*x5-3*

     &  x3*x6*x5-3*x4**2*x5-3*x4*x10*x5-x4*x6*x5)

        fm(3,3)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x3+x8+x6

     &  +2*x5)+8*pq**2*ph**2*(-x1+2*x3-x6)+16*pq**2*(x2*x5-2*x3*

     &  x8-2*x3*x6+4*x3*x5+x8*x5)+8*ph**2*x3*x6-16*x3*x8*x5

        fm(3,4)=16*pq**4*(-4*x1-x3+x8-x6)+4*pq**2*ph**2*(-2*x1-x3-

     &  x6)+16*pq**2*(-2*x1**2-3*x1*x2-2*x1*x3-3*x1*x8-2*x1*x6-3*

     &  x1*x5-2*x2*x3-2*x6*x5)-8*ph**2*x3*x6+8*(-x1*x2*x8-2*x1*x2

     &  *x5-x1*x8**2-x1*x8*x5+x2**2*x6-x2*x3*x5+x2*x8*x6-x2*x6*x5

     &  +x3*x8*x5+x3*x5**2)

        fm(3,5)=8*pq**4*(-2*x1+x10-x8-2*x6)+4*pq**2*(4*x1**2+2*x1*

     &  x2+4*x1*x3+4*x1*x4+6*x1*x10+4*x1*x9-2*x1*x8+8*x1*x7-2*x1*

     &  x5+4*x2*x3+3*x2*x10+2*x2*x6-4*x3**2-4*x3*x10+3*x3*x9+2*x3

     &  *x7-3*x4*x8-2*x4*x6+x10*x5+3*x9*x6-x8*x7+4*x7*x6)+8*(-x1

     &  **2*x9+x1**2*x8+x1*x2*x7-x1*x2*x6-x1*x3*x9+x1*x3*x8-x1*x3

     &  *x5+x1*x4*x8+x1*x4*x5+x1*x10*x8-x1*x9*x6+x1*x8*x7+x2*x3*

     &  x7-x2*x3*x6-x2*x4*x6-x2*x10*x6-x3**2*x5-x3*x10*x5-x3*x7*

     &  x5+x4*x6*x5)

        fm(3,6)=16*pq**6+4*pq**4*ph**2+16*pq**4*(-x1-x2+2*x3+2*x4+

     &  x10-x9-x8-x7-x6+x5)+4*pq**2*ph**2*(x1+2*x3+2*x4+x10+x7+x6

     &  )+8*pq**2*(4*x1*x3+4*x1*x4+4*x1*x10+4*x2*x3+4*x2*x4+4*x2*

     &  x10-x2*x5+4*x3*x5+4*x4*x5+2*x10*x5-x9*x5-x8*x5)-(8*ph**2*

     &  x1)*(x3+x4+x10)+16*x2*x5*(x3+x4+x10)

        fm(3,7)=8*pq**4*(3*x3+6*x4+3*x10+x9+2*x8+2*x7+x6)+2*pq**2*

     &  ph**2*(x3+2*x4+2*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+4*

     &  x1*x10+2*x1*x9-2*x1*x8+2*x2*x3+10*x2*x4+5*x2*x10+2*x2*x9+

     &  x2*x8+2*x2*x7+4*x2*x6-7*x3*x9+2*x3*x8-8*x3*x7+4*x3*x6+4*

     &  x3*x5+5*x4*x8+4*x4*x6+8*x4*x5+5*x10*x5-x9*x8-x9*x6+x9*x5+

     &  x8**2-x8*x7+2*x8*x6+2*x8*x5)+2*ph**2*(-x1*x10+x3*x7-2*x3*

     &  x6+x4*x6)+4*(-x1*x2*x9-2*x1*x2*x8+x1*x9*x8-x1*x8**2+x2**2

     &  *x7+2*x2**2*x6+3*x2*x4*x5+2*x2*x10*x5-2*x2*x9*x6+x2*x8*x7

     &  +x2*x8*x6-2*x3*x9*x5+x3*x8*x5+x4*x8*x5)

        fm(3,8)=8*pq**4*(3*x3+6*x4+3*x10+2*x9+x8+2*x7+x6)+2*pq**2*

     &  ph**2*(3*x3+6*x4+3*x10-2*x7-x6)+4*pq**2*(4*x1*x3+8*x1*x4+

     &  4*x1*x10+4*x2*x3+8*x2*x4+4*x2*x10-8*x3*x9+4*x3*x8-8*x3*x7

     &  +4*x3*x6+6*x3*x5+4*x4*x8+4*x4*x6+12*x4*x5+6*x10*x5+2*x9*

     &  x5+x8*x5)+4*ph**2*(-x1*x3-2*x1*x4-x1*x10+2*x3*x7-x3*x6-x4

     &  *x6)+8*x5*(x2*x3+2*x2*x4+x2*x10-2*x3*x9+x3*x8+x4*x8)

        fm(4,4)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+2*x2+x3+x8+2*

     &  x6+x5)+8*pq**2*ph**2*(-x1-x3+2*x6)+16*pq**2*(x2*x8+4*x2*

     &  x6+x2*x5-2*x3*x6-2*x8*x6)+8*ph**2*x3*x6-16*x2*x8*x6

        fm(4,5)=16*pq**6+8*pq**4*(-2*x1+x2-2*x3-2*x4-4*x10-x9+x8-4

     &  *x7+2*x6+x5)+8*pq**2*(-2*x1*x2-2*x2*x3-2*x2*x10-2*x2*x7+

     &  x2*x6+2*x3*x6-2*x4*x6+4*x10*x6-x9*x6-x8*x6)+16*x2*x6*(x3+

     &  x10)

        fm(4,6)=16*pq**6-4*pq**4*ph**2+8*pq**4*(-2*x1+2*x2-4*x3-2*

     &  x4-8*x10+x9+x8-4*x7-2*x6+2*x5)-(4*pq**2*ph**2)*(x1+x3+x10

     &  +x7)+8*pq**2*(-2*x1*x2-2*x1*x10+x1*x9+x1*x8-2*x1*x5+x2**2

     &  -4*x2*x3-5*x2*x10+x2*x9-3*x2*x7-x2*x6+x2*x5+x3*x9+2*x3*x7

     &  -3*x3*x5+x4*x8+2*x4*x6-x4*x5-5*x10*x5+x9*x8+x9*x6+x8*x7+

     &  x8*x5-4*x7*x5+x5**2)-(16*x2*x5)*(x1+x3+x10+x7)

        fm(4,7)=8*pq**4*(-x3-2*x4-3*x10-2*x9-x8-6*x7-3*x6)+2*pq**2

     &  *ph**2*(x3+2*x4-3*x10-6*x7-3*x6)+4*pq**2*(-4*x1*x10-8*x1*

     &  x7-4*x1*x6-6*x2*x10-2*x2*x9-x2*x8-12*x2*x7-6*x2*x6-4*x3*

     &  x7-4*x3*x6+8*x4*x6-4*x10*x5+8*x9*x6-4*x8*x7-4*x8*x6-8*x7*

     &  x5-4*x6*x5)+4*ph**2*(x1*x10+2*x1*x7+x1*x6+x3*x7+x3*x6-2*

     &  x4*x6)+8*x2*(-x10*x5+2*x9*x6-x8*x7-x8*x6-2*x7*x5-x6*x5)

        fm(4,8)=8*pq**4*(-x3-2*x4-3*x10-x9-2*x8-6*x7-3*x6)+2*pq**2

     &  *ph**2*(x3+2*x4-2*x10-2*x7-x6)+4*pq**2*(-4*x1*x10-2*x1*x9

     &  +2*x1*x8-8*x1*x7-4*x1*x6-5*x2*x10-x2*x9-2*x2*x8-8*x2*x7-4

     &  *x2*x6+x3*x9-2*x3*x8-4*x3*x7-4*x3*x6-4*x3*x5+x4*x8+8*x4*

     &  x6-2*x4*x5-5*x10*x5+x9*x8+7*x9*x6-2*x9*x5-x8**2-5*x8*x7-2

     &  *x8*x6-x8*x5-10*x7*x5-2*x6*x5)+2*ph**2*(x1*x10-x3*x7+2*x3

     &  *x6-x4*x6)+4*(-x1*x9*x8+x1*x9*x5+x1*x8**2+2*x1*x8*x5-2*x2

     &  *x10*x5+2*x2*x9*x6-x2*x8*x7-x2*x8*x6-3*x2*x7*x5+2*x3*x9*

     &  x5-x3*x8*x5-2*x3*x5**2-x4*x8*x5-x4*x5**2)

        fm(5,5)=16*pq**6+16*pq**4*(-x1-x3+x4-x10-x7+x6)+16*pq**2*(

     &  x3*x6+x4*x10+x4*x7+x4*x6+x10*x6)-16*x4*x10*x6

        fm(5,6)=16*pq**6+8*pq**4*(-2*x1+x2-4*x3+2*x4-4*x10+x9-x8-2

     &  *x7-2*x6+x5)+8*pq**2*(-2*x1*x5-2*x3*x5+4*x4*x10-x4*x9-x4*

     &  x8+2*x4*x7-2*x4*x6+x4*x5-2*x10*x5-2*x7*x5)+16*x4*x5*(x10+

     &  x7)

        fm(5,7)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+

     &  4*x1*x4+2*x1*x10+x1*x9-x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*

     &  x4-3*x2*x10-2*x2*x7-x2*x6+6*x3**2+6*x3*x4+6*x3*x10+x3*x9+

     &  3*x3*x8+2*x3*x7+4*x3*x6+2*x3*x5+6*x4*x10+2*x4*x8+4*x4*x7+

     &  2*x4*x6+x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-x10*x5+

     &  2*x9*x7+2*x9*x6-x8*x6+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(-

     &  x1**2*x9+x1**2*x8+2*x1*x2*x10+3*x1*x2*x7+3*x1*x2*x6-x1*x3

     &  *x9-x1*x3*x8-x1*x3*x5-x1*x4*x8+x1*x4*x5-x1*x10*x9-x1*x10*

     &  x8-x1*x9*x7+x1*x8*x7+x2*x3*x7+3*x2*x3*x6-x2*x4*x6+3*x2*

     &  x10*x7+3*x2*x10*x6+3*x2*x7**2+3*x2*x7*x6+x3**2*x5+2*x3*x4

     &  *x5+x3*x10*x5-x3*x7*x5+x4*x10*x5+x4*x7*x5)

        fm(5,8)=8*pq**4*(-2*x3-x4-3*x10-2*x7-x6)+4*pq**2*(2*x1*x3+

     &  4*x1*x4+2*x1*x10-x1*x9+x1*x8+2*x1*x7+4*x1*x6-2*x2*x3-x2*

     &  x4-x2*x10+2*x2*x7+x2*x6+6*x3**2+6*x3*x4+6*x3*x10+2*x3*x8+

     &  2*x3*x7+4*x3*x6-2*x3*x5+6*x4*x10-x4*x9+2*x4*x8+4*x4*x7+2*

     &  x4*x6-x4*x5+3*x10*x9+3*x10*x8+6*x10*x7+6*x10*x6-3*x10*x5+

     &  3*x9*x7+2*x9*x6+x8*x7+6*x7**2+6*x7*x6-2*x7*x5-x6*x5)+4*(

     &  x1**2*x9-x1**2*x8-x1*x2*x7+x1*x2*x6+x1*x3*x9-x1*x3*x8+3*

     &  x1*x3*x5+3*x1*x4*x5-x1*x10*x9-x1*x10*x8+2*x1*x10*x5-x1*x9

     &  *x7-x1*x9*x6-x1*x8*x7-x2*x3*x7+x2*x3*x6+x2*x10*x7+x2*x10*

     &  x6+x2*x7**2+2*x2*x7*x6+3*x3**2*x5+3*x3*x4*x5+3*x3*x10*x5+

     &  x3*x7*x5+3*x4*x10*x5+3*x4*x7*x5-x4*x6*x5)

        fm(6,6)=64*pq**6+16*pq**4*ph**2+32*pq**4*(x1+x2+2*x4+x9+x7

     &  +2*x5)+8*pq**2*ph**2*(-x1+2*x4-x7)+16*pq**2*(x2*x5-2*x4*

     &  x9-2*x4*x7+4*x4*x5+x9*x5)+8*ph**2*x4*x7-16*x4*x9*x5

        fm(6,7)=8*pq**4*(-6*x3-3*x4-3*x10-2*x9-x8-x7-2*x6)+2*pq**2

     &  *ph**2*(-2*x3-x4-2*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*x4

     &  -4*x1*x10+2*x1*x9-2*x1*x8-10*x2*x3-2*x2*x4-5*x2*x10-x2*x9

     &  -2*x2*x8-4*x2*x7-2*x2*x6-5*x3*x9-4*x3*x7-8*x3*x5-2*x4*x9+

     &  7*x4*x8-4*x4*x7+8*x4*x6-4*x4*x5-5*x10*x5-x9**2+x9*x8-2*x9

     &  *x7+x9*x6-2*x9*x5+x8*x7-x8*x5)+2*ph**2*(x1*x10-x3*x7+2*x4

     &  *x7-x4*x6)+4*(2*x1*x2*x9+x1*x2*x8+x1*x9**2-x1*x9*x8-2*x2

     &  **2*x7-x2**2*x6-3*x2*x3*x5-2*x2*x10*x5-x2*x9*x7-x2*x9*x6+

     &  2*x2*x8*x7-x3*x9*x5-x4*x9*x5+2*x4*x8*x5)

        fm(6,8)=8*pq**4*(-6*x3-3*x4-3*x10-x9-2*x8-x7-2*x6)+2*pq**2

     &  *ph**2*(-6*x3-3*x4-3*x10+x7+2*x6)+4*pq**2*(-8*x1*x3-4*x1*

     &  x4-4*x1*x10-8*x2*x3-4*x2*x4-4*x2*x10-4*x3*x9-4*x3*x7-12*

     &  x3*x5-4*x4*x9+8*x4*x8-4*x4*x7+8*x4*x6-6*x4*x5-6*x10*x5-x9

     &  *x5-2*x8*x5)+4*ph**2*(2*x1*x3+x1*x4+x1*x10+x3*x7+x4*x7-2*

     &  x4*x6)+8*x5*(-2*x2*x3-x2*x4-x2*x10-x3*x9-x4*x9+2*x4*x8)

        fm(7,7)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+9*

     &  x2*x10+7*x3*x7+2*x3*x6+2*x4*x7+7*x4*x6+x10*x5+2*x9*x7+7*

     &  x9*x6+7*x8*x7+2*x8*x6)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2

     &  *x4*x7-7*x4*x6)+4*x2*(x10*x5+2*x9*x7+7*x9*x6+7*x8*x7+2*x8

     &  *x6)

        fm(7,8)=72*pq**4*x10+2*pq**2*ph**2*x10+4*pq**2*(2*x1*x10+

     &  10*x2*x10+7*x3*x9+2*x3*x8+14*x3*x7+4*x3*x6+2*x4*x9+7*x4*

     &  x8+4*x4*x7+14*x4*x6+10*x10*x5+x9**2+7*x9*x8+2*x9*x7+7*x9*

     &  x6+x8**2+7*x8*x7+2*x8*x6)+2*ph**2*(7*x1*x10-7*x3*x7-2*x3*

     &  x6-2*x4*x7-7*x4*x6)+2*(-2*x1*x9**2-14*x1*x9*x8-2*x1*x8**2

     &  +2*x2*x10*x5+2*x2*x9*x7+7*x2*x9*x6+7*x2*x8*x7+2*x2*x8*x6+

     &  7*x3*x9*x5+2*x3*x8*x5+2*x4*x9*x5+7*x4*x8*x5)

        fm(8,8)=72*pq**4*x10+18*pq**2*ph**2*x10+8*pq**2*(x1*x10+x2

     &  *x10+7*x3*x9+2*x3*x8+7*x3*x7+2*x3*x6+2*x4*x9+7*x4*x8+2*x4

     &  *x7+7*x4*x6+9*x10*x5)+2*ph**2*(-x1*x10-7*x3*x7-2*x3*x6-2*

     &  x4*x7-7*x4*x6)+4*x5*(x2*x10+7*x3*x9+2*x3*x8+2*x4*x9+7*x4*

     &  x8)

        fm(9,9)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+

     &  x3*x7+x4*x6-x10*x5+x9*x6+x8*x7)+ph**2*(x1*x10-x3*x7-x4*x6

     &  )+2*x2*(-x10*x5+x9*x6+x8*x7)

        fm(9,10)=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*

     &  x10+2*x3*x9+2*x3*x7+2*x4*x6-2*x10*x5+x9*x8+2*x8*x7)+ph**2

     &  *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x8*x7+x3*

     &  x9*x5)

        fmxx=-4*pq**4*x10-pq**2*ph**2*x10+2*pq**2*(-2*x1*x10-2*x2*

     &  x10+2*x4*x8+2*x4*x6+2*x3*x7-2*x10*x5+x9*x8+2*x9*x6)+ph**2

     &  *(x1*x10-x3*x7-x4*x6)+2*(-x1*x9*x8-x2*x10*x5+x2*x9*x6+x4*

     &  x8*x5)

        fm(9,10)=0.5d0*(fmxx+fm(9,10))

        fm(10,10)=-4*pq**4*x10-pq**2*ph**2*x10+4*pq**2*(-x1*x10-x2*x10+

     &  x3*x7+x4*x6-x10*x5+x9*x3+x8*x4)+ph**2*(x1*x10-x3*x7-x4*x6

     &  )+2*x5*(-x10*x2+x9*x3+x8*x4)


C...Repackage matrix elements.

        DO 200 i=1,8

          DO 190 j=1,8

            rm(i,j)=fm(i,j)

  190     CONTINUE

  200   CONTINUE

        rm(7,7)=fm(7,7)-2d0*fm(9,9)

        rm(7,8)=fm(7,8)-2d0*fm(9,10)

        rm(8,8)=fm(8,8)-2d0*fm(10,10)


C...Produce final result: matrix elements * colours * propagators.

        DO 220 i=1,8

          DO 210 j=i,8

            fac=8d0

            IF(i.EQ.j)fac=4d0

            wtqqbh=wtqqbh+rm(i,j)*fac*clr(i,j)/(dx(i)*dx(j))

  210     CONTINUE

  220   CONTINUE

        wtqqbh=-wtqqbh/256d0


      ELSE

C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.

        a11=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x2*x10+x3

     &  *x7+x4*x6+x9*x6+x8*x7)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x2)*(x9

     &  *x6+x8*x7)

        a12=-8d0*pq**4*x10+4d0*pq**2*(-x2*x10-x3*x9-2d0*x3*x7-x4*x8-

     &  2d0*x4*x6-x10*x5-x9*x8-x9*x6-x8*x7)+2d0*ph**2*(-x1*x10+x3*x7

     &  +x4*x6)+2d0*(2d0*x1*x9*x8-x2*x9*x6-x2*x8*x7-x3*x9*x5-x4*x8*

     &  x5)

        a22=-8d0*pq**4*x10-2d0*pq**2*ph**2*x10-(8d0*pq**2)*(x3*x9+x3*

     &  x7+x4*x8+x4*x6+x10*x5)+2d0*ph**2*(x3*x7+x4*x6)-(4d0*x5)*(x3

     &  *x9+x4*x8)


C...Produce final result: matrix elements * propagators.

        a11=a11/dx(7)**2

        a12=a12/(dx(7)*dx(8))

        a22=a22/dx(8)**2

        wtqqbh=-(a11+a22+2d0*a12)/8d0

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYMSIN

C...Initializes supersymmetry: finds sparticle masses and

C...branching ratios and stores this information.

C...AUTHOR: STEPHEN MRENNA


      SUBROUTINE pymsin


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint4/mwid(500),wids(500,5)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pypars/,/pyint4/,/pymssm/,

     &/pyssmt/


C...Local variables.

      INTEGER nstr

      DOUBLE PRECISION alfa,beta

      DOUBLE PRECISION tanb,al,be,cosa,cosb,sina,sinb,xw,aem,fact

      DOUBLE PRECISION pyalem

      INTEGER i,j,j1,j2,i1,i2,i3,iknt,k1

      INTEGER kc,lknt,idlam(200,3),idlam0(100,3),lknt0

      DOUBLE PRECISION xlam(0:200),xlam0(0:200),xall

      DOUBLE PRECISION wdtp(0:200),wdte(0:200,0:5)

      DOUBLE PRECISION aterm,tan2t,theta,denom

      DOUBLE PRECISION xarg,cos2b,xmw2,xmz2

      DOUBLE PRECISION cosw,sinw,wdmin,wdmax

      DOUBLE PRECISION delm,xmdif,brlim

      DOUBLE PRECISION dx,dy,ds,dmu2,dma2,dq2,du2,dd2,dl2,de2,dhu2,dhd2

      DOUBLE PRECISION arg,sgnmu,r,gam

      INTEGER is1,is2,is3,is4,js1,js2,js3,js4,ks1,ks2,ks3,ks4

      INTEGER imssm,kfhigg

      INTEGER irprty

      INTEGER kfsusy(36)

      DATA kfsusy/

     &1000001,2000001,1000002,2000002,1000003,2000003,

     &1000004,2000004,1000005,2000005,1000006,2000006,

     &1000011,2000011,1000012,2000012,1000013,2000013,

     &1000014,2000014,1000015,2000015,1000016,2000016,

     &1000021,1000022,1000023,1000025,1000035,1000024,

     &1000037,1000039,     25,     35,     36,     37/


C...Do nothing if SUSY not requested.

      imssm=imss(1)

      IF(imssm.EQ.0) RETURN


C...First part of routine: set masses and couplings.


C...Reset mixing values in sfermion sector to pure left/right.

      DO 100 i=1,16

        sfmix(i,1)=1d0

        sfmix(i,4)=1d0

        sfmix(i,2)=0d0

        sfmix(i,3)=0d0

  100 CONTINUE


C...Common couplings.

      tanb=rmss(5)

      beta=atan(tanb)

      cosb=cos(beta)

      sinb=tanb*cosb

      cos2b=cos(2d0*beta)

      alfa=rmss(18)

      xmw2=pmas(24,1)**2

      xmz2=pmas(23,1)**2

      xw=paru(102)


C...Define sparticle masses for a general MSSM simulation.

      IF(imssm.EQ.1) THEN

        IF(imss(9).EQ.0) rmss(22)=rmss(9)

        DO 110 i=1,5,2

          kc=pycomp(ksusy1+i)

          pmas(kc,1)=sqrt(rmss(8)**2-(2d0*xmw2+xmz2)*cos2b/6d0)

          kc=pycomp(ksusy2+i)

          pmas(kc,1)=sqrt(rmss(9)**2+(xmw2-xmz2)*cos2b/3d0)

          kc=pycomp(ksusy1+i+1)

          pmas(kc,1)=sqrt(rmss(8)**2+(4d0*xmw2-xmz2)*cos2b/6d0)

          kc=pycomp(ksusy2+i+1)

          pmas(kc,1)=sqrt(rmss(22)**2-(xmw2-xmz2)*cos2b*2d0/3d0)

  110   CONTINUE

        xarg=rmss(6)**2-pmas(24,1)**2*abs(cos(2d0*beta))

        IF(xarg.LT.0d0) THEN

          WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//

     &    ' FROM THE SUM RULE. '

          WRITE(mstu(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '

          RETURN

        ELSE

          xarg=sqrt(xarg)

        ENDIF

        DO 120 i=11,15,2

          pmas(pycomp(ksusy1+i),1)=rmss(6)

          pmas(pycomp(ksusy2+i),1)=rmss(7)

          pmas(pycomp(ksusy1+i+1),1)=xarg

          pmas(pycomp(ksusy2+i+1),1)=9999d0

  120   CONTINUE

        IF(imss(8).EQ.1) THEN

          rmss(13)=rmss(6)

          rmss(14)=rmss(7)

        ENDIF


C...Alternatively derive masses from SUGRA relations.

      ELSEIF(imssm.EQ.2) THEN

        CALL pyapps

      ENDIF


C...Add in extra D-term contributions.

      IF(imss(7).EQ.1) THEN

        r=0.43d0

        dx=rmss(23)

        dy=rmss(24)

        ds=rmss(25)

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

        WRITE(mstu(11),*) 'C  NEW DTERMS ADDED TO SCALAR MASSES   '

        WRITE(mstu(11),*) 'C   IN A U(B-L) THEORY                 '

        WRITE(mstu(11),*) 'C   DX = ',dx

        WRITE(mstu(11),*) 'C   DY = ',dy

        WRITE(mstu(11),*) 'C   DS = ',ds

        WRITE(mstu(11),*) 'C                                      '

        dy=r*dy-4d0/33d0*(1d0-r)*dx+(1d0-r)/33d0*ds

        WRITE(mstu(11),*) 'C   DY AT THE WEAK SCALE = ',dy

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

        dq2=dy/6d0-dx/3d0-ds/3d0

        du2=-2d0*dy/3d0-dx/3d0-ds/3d0

        dd2=dy/3d0+dx-2d0*ds/3d0

        dl2=-dy/2d0+dx-2d0*ds/3d0

        de2=dy-dx/3d0-ds/3d0

        dhu2=dy/2d0+2d0*dx/3d0+2d0*ds/3d0

        dhd2=-dy/2d0-2d0*dx/3d0+ds

        dmu2=(-dy/2d0-2d0/3d0*dx+(cosb**2-2d0*sinb**2/3d0)*ds)

     &  /abs(cos2b)

        dma2 = 2d0*dmu2+dhu2+dhd2

        DO 130 i=1,5,2

          kc=pycomp(ksusy1+i)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)

          kc=pycomp(ksusy2+i)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+dd2)

          kc=pycomp(ksusy1+i+1)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+dq2)

          kc=pycomp(ksusy2+i+1)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+du2)

  130   CONTINUE

        DO 140 i=11,15,2

          kc=pycomp(ksusy1+i)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)

          kc=pycomp(ksusy2+i)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+de2)

          kc=pycomp(ksusy1+i+1)

          pmas(kc,1)=sqrt(pmas(kc,1)**2+dl2)

  140   CONTINUE

        IF(rmss(4)**2+dmu2.LT.0d0) THEN

          WRITE(mstu(11),*) ' MU2 DRIVEN NEGATIVE '

          stop

        ENDIF

        sgnmu=sign(1d0,rmss(4))

        rmss(4)=sgnmu*sqrt(rmss(4)**2+dmu2)

        arg=rmss(10)**2*sign(1d0,rmss(10))+dq2

        rmss(10)=sign(sqrt(abs(arg)),arg)

        arg=rmss(11)**2*sign(1d0,rmss(11))+dd2

        rmss(11)=sign(sqrt(abs(arg)),arg)

        arg=rmss(12)**2*sign(1d0,rmss(12))+du2

        rmss(12)=sign(sqrt(abs(arg)),arg)

        arg=rmss(13)**2*sign(1d0,rmss(13))+dl2

        rmss(13)=sign(sqrt(abs(arg)),arg)

        arg=rmss(14)**2*sign(1d0,rmss(14))+de2

        rmss(14)=sign(sqrt(abs(arg)),arg)

        IF( rmss(19)**2 + dma2 .LE. 50d0 ) THEN

          WRITE(mstu(11),*) ' MA DRIVEN TOO LOW '

          stop

        ENDIF

        rmss(19)=sqrt(rmss(19)**2+dma2)

        rmss(6)=sqrt(rmss(6)**2+dl2)

        rmss(7)=sqrt(rmss(7)**2+de2)

        WRITE(mstu(11),*) ' MTL = ',rmss(10)

        WRITE(mstu(11),*) ' MBR = ',rmss(11)

        WRITE(mstu(11),*) ' MTR = ',rmss(12)

        WRITE(mstu(11),*) ' SEL = ',rmss(6),rmss(13)

        WRITE(mstu(11),*) ' SER = ',rmss(7),rmss(14)

      ENDIF


C...Fix the third generation sfermions.

      CALL pythrg

      xarg=rmss(13)**2-pmas(24,1)**2*abs(cos2b)

      IF(xarg.LT.0d0) THEN

        WRITE(mstu(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'//

     &  ' THE SUM RULE. '

        WRITE(mstu(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '

        RETURN

      ELSE

        pmas(pycomp(ksusy1+16),1)=sqrt(xarg)

      ENDIF


C...Fix the neutralino--chargino--gluino sector.

      CALL pyinom


C...Fix the Higgs sector.

      CALL pyhggm(alfa)


C...Choose the Gunion-Haber convention.

      alfa=-alfa

      rmss(18)=alfa


C...Print information on mass parameters.

      IF(imssm.EQ.2.AND.mstp(122).GT.0) THEN

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

        WRITE(mstu(11),*) ' USING APPROXIMATE SUGRA RELATIONS '

        WRITE(mstu(11),*) ' M0 = ',rmss(8)

        WRITE(mstu(11),*) ' M1/2=',rmss(1)

        WRITE(mstu(11),*) ' TANB=',rmss(5)

        WRITE(mstu(11),*) ' MU = ',rmss(4)

        WRITE(mstu(11),*) ' AT = ',rmss(16)

        WRITE(mstu(11),*) ' MA = ',rmss(19)

        WRITE(mstu(11),*) ' MTOP=',pmas(6,1)

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

      ENDIF

      IF(imss(20).EQ.1) THEN

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

        WRITE(mstu(11),*) ' DEBUG MODE '

        WRITE(mstu(11),*) ' UMIX = ',umix(1,1),umix(1,2),

     &  umix(2,1),umix(2,2)

        WRITE(mstu(11),*) ' VMIX = ',vmix(1,1),vmix(1,2),

     &  vmix(2,1),vmix(2,2)

        WRITE(mstu(11),*) ' ZMIX = ',zmix

        WRITE(mstu(11),*) ' ALFA = ',alfa

        WRITE(mstu(11),*) ' BETA = ',beta

        WRITE(mstu(11),*) ' STOP = ',(sfmix(6,i),i=1,4)

        WRITE(mstu(11),*) ' SBOT = ',(sfmix(5,i),i=1,4)

        WRITE(mstu(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

      ENDIF


C...Set up the Higgs couplings - needed here since initialization

C...in PYINRE did not yet occur when PYWIDT is called below.

      al=alfa

      be=beta

      sina=sin(al)

      cosa=cos(al)

      cosb=cos(be)

      sinb=tanb*cosb

C...tanb (used for H+)

      paru(141)=tanb


C...Firstly: h

C...Coupling to d-type quarks

      paru(161)=sina/cosb

C...Coupling to u-type quarks

      paru(162)=-cosa/sinb

C...Coupling to leptons

      paru(163)=paru(161)

C...Coupling to Z

      paru(164)=sin(be-al)

C...Coupling to W

      paru(165)=paru(164)

C...Coupling to H+

      paru(168)=-sin(be-al)-cos(2d0*be)*sin(be+al)/2d0/(1d0-xw)


C...Secondly: H

C...Coupling to d-type quarks

      paru(171)=-cosa/cosb

C...Coupling to u-type quarks

      paru(172)=-sina/sinb

C...Coupling to leptons

      paru(173)=paru(171)

C...Coupling to Z

      paru(174)=cos(be-al)

C...Coupling to W

      paru(175)=paru(174)

C...Coupling to h

      paru(176)=cos(2d0*al)*cos(be+al)-2d0*sin(2d0*al)*sin(be+al)

C...Coupling to A

      paru(177)=cos(2d0*be)*cos(be+al)

C...Coupling to H+

      paru(178)=-cos(be-al)+cos(2d0*be)*cos(be+al)/2d0/(1d0-xw)


C...Thirdly, A

C...Coupling to d-type quarks

      paru(181)=tanb

C...Coupling to u-type quarks

      paru(182)=1d0/paru(181)

C...Coupling to leptons

      paru(183)=paru(181)

      paru(184)=0d0

      paru(185)=0d0

C...Coupling to Z h

      paru(186)=cos(be-al)

C...Coupling to Z H

      paru(187)=sin(be-al)

      paru(188)=0d0

      paru(189)=0d0

      paru(190)=0d0


C...Finally: H+

C...Coupling to W h

      paru(195)=cos(be-al)


C...Tell that all Higgs couplings have been set.

      mstp(4)=1


C...Second part of routine: set decay modes and branching ratios.


C...Allow chi10 -> gravitino + gamma or not.

      kc=pycomp(ksusy1+39)

      IF( imss(11) .NE. 0 ) THEN

        pmas(kc,1)=rmss(21)/1000000000d0

        pmas(kc,2)=0.0001d0

        irprty=0

        WRITE(mstu(11),*) ' ALLOWING DECAYS TO GRAVITINOS '

      ELSE

        pmas(kc,1)=9999d0

        irprty=1

      ENDIF


C...Loop over sparticle and Higgs species.

      pmchi1=pmas(pycomp(ksusy1+22),1)

      DO 200 i=1,36

        kf=kfsusy(i)

        kc=pycomp(kf)

        lknt=0


C...Sfermion decays.

        IF(i.LE.24) THEN

C...First check to see if sneutrino is lighter than chi10.

          IF((i.EQ.15.OR.i.EQ.19.OR.i.EQ.23).AND.

     &    pmas(kc,1).LT.pmchi1) THEN

          ELSE

            CALL pysfdc(kf,xlam,idlam,lknt)

          ENDIF


C...Gluino decays.

        ELSEIF(i.EQ.25) THEN

          CALL pyglui(kf,xlam,idlam,lknt)


C...Neutralino decays.

        ELSEIF(i.GE.26.AND.i.LE.29) THEN

          CALL pynjdc(kf,xlam,idlam,lknt)

C...chi10 stable or chi10 -> gravitino + gamma.

          IF(i.EQ.26.AND.irprty.EQ.1) THEN

            pmas(kc,2)=1d-6

            mdcy(kc,1)=0

            mwid(kc)=0

          ENDIF


C...Chargino decays.

        ELSEIF(i.GE.30.AND.i.LE.31) THEN

          CALL pycjdc(kf,xlam,idlam,lknt)


C...Gravitino is stable.

        ELSEIF(i.EQ.32) THEN

          mdcy(kc,1)=0

          mwid(kc)=0


C...Higgs decays.

        ELSEIF(i.GE.33.AND.i.LE.36) THEN

C...Calculate decays to non-SUSY particles.

          CALL pywidt(kf,pmas(kc,1)**2,wdtp,wdte)

          lknt=0

          DO 150 i1=0,100

            xlam(i1)=0d0

  150     CONTINUE

          DO 170 i1=1,mdcy(kc,3)

            k1=mdcy(kc,2)+i1-1

            IF(iabs(kfdp(k1,1)).GT.ksusy1.OR.

     &      iabs(kfdp(k1,2)).GT.ksusy1) goto 170

            xlam(i1)=wdtp(i1)

            xlam(0)=xlam(0)+xlam(i1)

            DO 160 j1=1,3

              idlam(i1,j1)=kfdp(k1,j1)

  160       CONTINUE

            lknt=lknt+1

  170     CONTINUE

C...Add the decays to SUSY particles.

          CALL pyhext(kf,xlam,idlam,lknt)

        ENDIF


C...Set stable particles.

        IF(lknt.EQ.0) THEN

          mdcy(kc,1)=0

          mwid(kc)=0

          pmas(kc,2)=1d-6

          pmas(kc,3)=1d-5

          pmas(kc,4)=0d0


C...Store branching ratios in the standard tables.

        ELSE

          idc=mdcy(kc,2)+mdcy(kc,3)-1

          delm=1d6

          DO 190 il=1,lknt

            idcsv=idc

  180       idc=idc+1

            IF(idc.EQ.mdcy(kc,2)+mdcy(kc,3)) idc=mdcy(kc,2)

            IF(idlam(il,1).EQ.kfdp(idc,1).AND.idlam(il,2).EQ.

     &      kfdp(idc,2).AND.idlam(il,3).EQ.kfdp(idc,3)) THEN

              brat(idc)=xlam(il)/xlam(0)

              xmdif=pmas(kc,1)

              IF(mdme(idc,1).GE.1) THEN

                xmdif=xmdif-pmas(pycomp(kfdp(idc,1)),1)-

     &          pmas(pycomp(kfdp(idc,2)),1)

                IF(kfdp(idc,3).NE.0) xmdif=xmdif-

     &          pmas(pycomp(kfdp(idc,3)),1)

              ENDIF

              IF(i.LE.32) THEN

                IF(xmdif.GE.0d0) THEN

                  delm=min(delm,xmdif)

                ELSE

                  WRITE(mstu(11),*) ' ERROR WITH DELM ',delm,xmdif

                  WRITE(mstu(11),*) ' KF = ',kf

                  WRITE(mstu(11),*) ' KF(decay) = ',(kfdp(idc,j),j=1,3)

                ENDIF

              ENDIF

              goto 190

            ELSEIF(idc.EQ.idcsv) THEN

              WRITE(mstu(11),*) ' Error in PYMSIN: SUSY decay ',

     &        'channel not recognized:'

              WRITE(mstu(11),*) kf,' -> ',(idlam(i,j),j=1,3)

              goto 190

            ELSE

              goto 180

            ENDIF

  190     CONTINUE


C...Store width, cutoff and lifetime.

          pmas(kc,2)=xlam(0)

          IF(pmas(kc,2).LT.0.1d0*delm) THEN

            pmas(kc,3)=pmas(kc,2)*10d0

          ELSE

            pmas(kc,3)=0.95d0*delm

          ENDIF

          IF(pmas(kc,2).NE.0d0) THEN

            pmas(kc,4)=paru(3)/pmas(kc,2)*1d-12

          ENDIF

        ENDIF

  200 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYAPPS

C...Uses approximate analytical formulae to determine the full set of

C...MSSM parameters from SUGRA input.

C...See M. Drees and S.P. Martin, hep-ph/9504124


      SUBROUTINE pyapps


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pydat1/,/pydat2/,/pymssm/


      xmt=pmas(6,1)

      xmz2=pmas(23,1)**2

      xmw2=pmas(24,1)**2

      tanb=rmss(5)

      beta=atan(tanb)

      xw=paru(102)

      xmg=rmss(1)

      xmg2=xmg*xmg

      xm0=rmss(8)

      xm02=xm0*xm0

      at=rmss(16)

      rmss(15)=at

      rmss(17)=at

      cosb=cos(beta)

      sinb=tanb*cosb


      dterm=xmz2*cos(2d0*beta)

      xmer=sqrt(xm02+0.15d0*xmg2-xw*dterm)

      xmel=sqrt(xm02+0.52d0*xmg2-(0.5d0-xw)*dterm)

      rmss(6)=xmel

      rmss(7)=xmer

      xmur=sqrt(pyrnmq(2,2d0/3d0*xw*dterm))

      xmdr=sqrt(pyrnmq(3,-1d0/3d0*xw*dterm))

      xmul=sqrt(pyrnmq(1,(0.5d0-2d0/3d0*xw)*dterm))

      xmdl=sqrt(pyrnmq(1,-(0.5d0-1d0/3d0*xw)*dterm))

      DO 100 i=1,5,2

        pmas(pycomp(ksusy1+i),1)=xmdl

        pmas(pycomp(ksusy2+i),1)=xmdr

        pmas(pycomp(ksusy1+i+1),1)=xmul

        pmas(pycomp(ksusy2+i+1),1)=xmur

  100 CONTINUE

      xarg=xmel**2-xmw2*abs(cos(2d0*beta))

      IF(xarg.LT.0d0) THEN

        WRITE(mstu(11),*) ' SNEUTRINO MASS IS NEGATIVE'//

     &  ' FROM THE SUM RULE. '

        WRITE(mstu(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '

        RETURN

      ELSE

        xarg=sqrt(xarg)

      ENDIF

      DO 110 i=11,15,2

        pmas(pycomp(ksusy1+i),1)=xmel

        pmas(pycomp(ksusy2+i),1)=xmer

        pmas(pycomp(ksusy1+i+1),1)=xarg

        pmas(pycomp(ksusy2+i+1),1)=9999d0

  110 CONTINUE

      xmnu=xarg


      rmt=pyrnmt(xmt)

      xtop=(rmt/150d0/sinb)**2*(.9d0*xm02+2.1d0*xmg2+

     &(1d0-(rmt/190d0/sinb)**3)*(.24d0*at**2+at*xmg))

      rmb=3d0

      xbot=(rmb/150d0/cosb)**2*(.9d0*xm02+2.1d0*xmg2+

     &(1d0-(rmb/190d0/cosb)**3)*(.24d0*at**2+at*xmg))

      xtau=1d-4/cosb**2*(xm02+0.15d0*xmg2+at**2/3d0)

      atp=at*(1d0-(rmt/190d0/sinb)**2)+xmg*(3.47d0-1.9d0*(rmt/190d0/

     &sinb)**2)

      rmss(16)=atp

      xmu2=-xm02-0.52d0*xmg2-0.5d0*xmz2+xtop/(1d0-1d0/tanb**2)

      xma2=(xmnu**2+xmu2-xbot-xtau/3d0)/sinb**2

      xmu=sign(sqrt(xmu2),rmss(4))

      rmss(4)=xmu

      rmss(19)=sqrt(xma2)

      arg=xm02+0.15d0*xmg2-2d0*xtau/3d0-xw*dterm

      IF(arg.GT.0d0) THEN

        rmss(14)=sqrt(arg)

      ELSE

        WRITE(mstu(11),*) ' RIGHT STAU MASS < 0 '

        stop

      ENDIF

      arg=xm02+0.52d0*xmg2-xtau/3d0-(0.5d0-xw)*dterm

      IF(arg.GT.0d0) THEN

        rmss(13)=sqrt(arg)

      ELSE

        WRITE(mstu(11),*) ' LEFT STAU MASS < 0 '

        stop

      ENDIF

      arg=pyrnmq(1,-(xbot+xtop)/3d0)

      IF(arg.GT.0d0) THEN

        rmss(10)=sqrt(arg)

      ELSE

        rmss(10)=-sqrt(-arg)

      ENDIF

      arg=pyrnmq(2,-2d0*xtop/3d0)

      IF(arg.GT.0d0) THEN

        rmss(12)=sqrt(arg)

      ELSE

        rmss(12)=-sqrt(-arg)

      ENDIF

      arg=pyrnmq(3,-2d0*xbot/3d0)

      IF(arg.GT.0d0) THEN

        rmss(11)=sqrt(arg)

      ELSE

        rmss(11)=-sqrt(-arg)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYRNMQ

C...Determines the running mass of quarks.


      FUNCTION pyrnmq(ID,DTERM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblock.

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pymssm/


C...Local variables.

      DOUBLE PRECISION pi,r

      DOUBLE PRECISION tol

      DOUBLE PRECISION ci(3)

      EXTERNAL pyalps

      DATA tol/0.001d0/

      DATA pi,r/3.141592654d0,.61803399d0/

      DATA ci/0.47d0,0.07d0,0.02d0/


      c=1d0-r

      ca=ci(id)

      ag=(0.71d0)**2/4d0/pi

      ag=rmss(20)

      xm0=rmss(8)

      xmg=rmss(1)

      xm02=xm0*xm0

      xmg2=xmg*xmg


      as=pyalps(xm02+6d0*xmg2)

      cg=8d0/9d0*((as/ag)**2-1d0)

      bx=xm02+(ca+cg)*xmg2+dterm

      ax=min(50d0**2,0.5d0*bx)

      cx=max(2000d0**2,2d0*bx)


      x0=ax

      x3=cx

      IF(abs(cx-bx).GT.abs(bx-ax))THEN

        x1=bx

        x2=bx+c*(cx-bx)

      ELSE

        x2=bx

        x1=bx-c*(bx-ax)

      ENDIF

      as1=pyalps(x1)

      cg=8d0/9d0*((as1/ag)**2-1d0)

      f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)

      as2=pyalps(x2)

      cg=8d0/9d0*((as2/ag)**2-1d0)

      f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)

  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN

        IF(f2.LT.f1) THEN

          x0=x1

          x1=x2

          x2=r*x1+c*x3

          f1=f2

          as2=pyalps(x2)

          cg=8d0/9d0*((as2/ag)**2-1d0)

          f2=abs(xm02+(ca+cg)*xmg2+dterm-x2)

        ELSE

          x3=x2

          x2=x1

          x1=r*x2+c*x0

          f2=f1

          as1=pyalps(x1)

          cg=8d0/9d0*((as1/ag)**2-1d0)

          f1=abs(xm02+(ca+cg)*xmg2+dterm-x1)

        ENDIF

        goto 100

      ENDIF

      IF(f1.LT.f2) THEN

        pyrnmq=x1

        xmin=x1

      ELSE

        pyrnmq=x2

        xmin=x2

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYRNMT

C...Determines the running mass of the top quark.


      FUNCTION pyrnmt(XMT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblock.

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pymssm/


C...Local variables.

      DOUBLE PRECISION xmt

      DOUBLE PRECISION pi,r

      DOUBLE PRECISION tol

      EXTERNAL pyalps

      DATA tol/0.001d0/

      DATA pi,r/3.141592654d0,0.61803399d0/


      c=1d0-r


      bx=xmt

      ax=min(50d0,bx*0.5d0)

      cx=max(300d0,2d0*bx)


      x0=ax

      x3=cx

      IF(abs(cx-bx).GT.abs(bx-ax))THEN

        x1=bx

        x2=bx+c*(cx-bx)

      ELSE

        x2=bx

        x1=bx-c*(bx-ax)

      ENDIF

      as1=pyalps(x1**2)/pi

      f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)

      as2=pyalps(x2**2)/pi

      f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)

  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN

        IF(f2.LT.f1) THEN

          x0=x1

          x1=x2

          x2=r*x1+c*x3

          f1=f2

          as2=pyalps(x2**2)/pi

          f2=abs(xmt/(1d0+4d0/3d0*as2+11d0*as2**2)-x2)

        ELSE

          x3=x2

          x2=x1

          x1=r*x2+c*x0

          f2=f1

          as1=pyalps(x1**2)/pi

          f1=abs(xmt/(1d0+4d0/3d0*as1+11d0*as1**2)-x1)

        ENDIF

        goto 100

      ENDIF

      IF(f1.LT.f2) THEN

        pyrnmt=x1

        xmin=x1

      ELSE

        pyrnmt=x2

        xmin=x2

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYTHRG

C...Calculates the mass eigenstates of the third generation sfermions.

C...Created:  5-31-96


      SUBROUTINE pythrg


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/


C...Local variables.

      DOUBLE PRECISION beta

      DOUBLE PRECISION pyrnmt

      DOUBLE PRECISION am2(2,2),rt(2,2),di(2,2)

      DOUBLE PRECISION xmz2,xmw2,tanb,xmu,cos2b,xmql2,xmqr2

      DOUBLE PRECISION xmf,xmf2,diff,same,xmf12,xmf22,small

      DOUBLE PRECISION sin2t,cos2t,twot,atr,amqr,xxx,yyy,amql

      INTEGER id1(3),id2(3),id3(3),id4(3)

      INTEGER if,i,j,ii,jj,it,l

      LOGICAL dterm

      DATA small/1d-3/

      DATA id1/10,10,13/

      DATA id2/5,6,15/

      DATA id3/15,16,17/

      DATA id4/11,12,14/

      DATA dterm/.true./


      xmz2=pmas(23,1)**2

      xmw2=pmas(24,1)**2

      tanb=rmss(5)

      xmu=-rmss(4)

      beta=atan(tanb)

      cos2b=cos(2d0*beta)


C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS


      iopt=imss(5)

      IF(iopt.EQ.1) THEN

        ctt=rmss(27)

        ctt2=ctt**2

        stt2=1d0-ctt2

        stt=sqrt(stt2)

        xm12=rmss(12)**2

        xm22=rmss(10)**2

        xmql2=ctt2*xm12+stt2*xm22

        xmqr2=stt2*xm12+ctt2*xm22

        xmfr=pmas(6,1)

        xmf2=pyrnmt(xmfr)**2

        atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)

        atmt=sqrt(xmf2)*(atop+xmu/tanb)

        xtest=(xmql2-xmqr2)*(ctt2-stt2)

        IF(xtest.GT.4d0*stt*ctt*atmt) THEN

         stt=-stt

         atop=-xmu/tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)

        ENDIF

        rmss(16)=atop

C......SUBTRACT OUT D-TERM AND FERMION MASS

        xmql2=xmql2-xmf2-(4d0*xmw2-xmz2)*cos2b/6d0

        xmqr2=xmqr2-xmf2+(xmw2-xmz2)*cos2b*2d0/3d0

        IF(xmql2.GE.0d0) THEN

          rmss(10)=sqrt(xmql2)

        ELSE

          rmss(10)=-sqrt(-xmql2)

        ENDIF

        IF(xmqr2.GE.0d0) THEN

          rmss(12)=sqrt(xmqr2)

        ELSE

          rmss(12)=-sqrt(-xmqr2)

        ENDIF

C SAME FOR SBOTTOM SQUARK

        ctt=rmss(26)

        ctt2=ctt**2

        stt2=1d0-ctt2

        stt=max(sqrt(stt2),1d-6)

        xmf=3d00

        xmf2=xmf**2

        xm12=rmss(11)**2

        xmql2=rmss(10)**2-(2d0*xmw2+xmz2)*cos2b/6d0+xmf2

        IF(abs(ctt).EQ.1d0) THEN

          xm22=xm12

          xm12=xmql2

          xmqr2=xm22

        ELSEIF(ctt.EQ.0d0) THEN

          xm22=xmql2

          xmqr2=xm12

        ELSE

          xm22=(xmql2-ctt2*xm12)/stt2

          xmqr2=stt2*xm12+ctt2*xm22

        ENDIF

        abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)

        atmt=sqrt(xmf2)*(abot+xmu*tanb)

        xtest=(xmql2-xmqr2)*(ctt2-stt2)

        IF(xtest.GT.4d0*stt*ctt*atmt) THEN

          stt=-stt

          abot=-xmu*tanb+ctt*stt*(xm22-xm12)/sqrt(xmf2)

        ENDIF

        rmss(15)=abot

C......SUBTRACT OUT D-TERM AND FERMION MASS

        xmqr2=xmqr2-(xmw2-xmz2)*cos2b/3d0-xmf2

        IF(xmqr2.GE.0d0) THEN

          rmss(11)=sqrt(xmqr2)

        ELSE

          rmss(11)=-sqrt(-xmqr2)

        ENDIF

      ENDIF


      DO 170 l=1,3

        amql=rmss(id1(l))

        IF(amql.LT.0d0) THEN

          xmql2=-amql**2

        ELSE

          xmql2=amql**2

        ENDIF

        if=id2(l)

        xmf=pmas(IF,1)

        IF(l.EQ.1) xmf=3d0

        IF(l.EQ.2) xmf=pyrnmt(xmf)

        xmf2=xmf**2

        atr=rmss(id3(l))

        amqr=rmss(id4(l))

        IF(amqr.LT.0d0) THEN

          xmqr2=-amqr**2

        ELSE

          xmqr2=amqr**2

        ENDIF

        am2(1,1)=xmql2+xmf2

        am2(2,2)=xmqr2+xmf2

        IF(dterm) THEN

          IF(l.EQ.1) THEN

            am2(1,1)=am2(1,1)-(2d0*xmw2+xmz2)*cos2b/6d0

            am2(2,2)=am2(2,2)+(xmw2-xmz2)*cos2b/3d0

            am2(1,2)=xmf*(atr+xmu*tanb)

          ELSEIF(l.EQ.2) THEN

            am2(1,1)=am2(1,1)+(4d0*xmw2-xmz2)*cos2b/6d0

            am2(2,2)=am2(2,2)-(xmw2-xmz2)*cos2b*2d0/3d0

            am2(1,2)=xmf*(atr+xmu/tanb)

          ELSEIF(l.EQ.3) THEN

            IF(imss(8).EQ.1) THEN

              am2(1,1)=rmss(6)**2

              am2(2,2)=rmss(7)**2

              am2(1,2)=0d0

              rmss(13)=rmss(6)

              rmss(14)=rmss(7)

            ELSE

              am2(1,2)=xmf*(atr+xmu*tanb)

            ENDIF

          ENDIF

        ENDIF

        am2(2,1)=am2(1,2)

        same=0.5d0*(am2(1,1)+am2(2,2))

        diff=0.5d0*sqrt((am2(1,1)-am2(2,2))**2+4d0*am2(1,2)*am2(2,1))

        xmf12=same-diff

        xmf22=same+diff

        IF(xmf12.LT.0d0) THEN

          WRITE(mstu(11),*) ' NEGATIVE**2 MASS FOR SFERMION '

          stop

        ENDIF

        it=0

        IF(xmf22-xmf12.GT.0d0) THEN

          rt(1,1) = sqrt((xmf22-am2(1,1))/(xmf22-xmf12))

          rt(2,2) = rt(1,1)

          rt(1,2) = -sign(sqrt(1d0-rt(1,1)**2),am2(1,2)/(xmf22-xmf12))

          rt(2,1) = -rt(1,2)

        ELSE

          rt(1,1) = 1d0

          rt(2,2) = rt(1,1)

          rt(1,2) = 0d0

          rt(2,1) = -rt(1,2)

        ENDIF

  100   CONTINUE

        it=it+1


        DO 140 i=1,2

          DO 130 jj=1,2

            di(i,jj)=0d0

            DO 120 ii=1,2

              DO 110 j=1,2

                di(i,jj)=di(i,jj)+rt(i,j)*am2(j,ii)*rt(jj,ii)

  110         CONTINUE

  120       CONTINUE

  130     CONTINUE

  140   CONTINUE


        IF(di(1,1).GT.di(2,2)) THEN

          WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION '

          WRITE(mstu(11),*) l,sqrt(xmf12),sqrt(xmf22)

          WRITE(mstu(11),*) am2

          WRITE(mstu(11),*) di

          WRITE(mstu(11),*) rt

          di(1,1)=-rt(2,1)

          di(2,2)=rt(1,2)

          di(1,2)=-rt(2,2)

          di(2,1)=rt(1,1)

          DO 160 i=1,2

            DO 150 j=1,2

              rt(i,j)=di(i,j)

  150       CONTINUE

  160     CONTINUE

          goto 100

        ELSEIF(abs(di(1,2)*di(2,1)/di(1,1)/di(2,2)).GT.small) THEN

          WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//

     &    ' OFF DIAGONAL ELEMENTS '

          WRITE(mstu(11),*) 'MASSES = ',l,sqrt(xmf12),sqrt(xmf22)

          WRITE(mstu(11),*) di

          WRITE(mstu(11),*) ' ROTATION = ',rt

C...STOP

        ELSEIF(di(1,1).LT.0d0.OR.di(2,2).LT.0d0) THEN

          WRITE(mstu(11),*) ' ERROR IN DIAGONALIZATION,'//

     &    ' NEGATIVE MASSES '

          stop

        ENDIF

        pmas(pycomp(ksusy1+if),1)=sqrt(xmf12)

        pmas(pycomp(ksusy2+if),1)=sqrt(xmf22)

        sfmix(IF,1)=rt(1,1)

        sfmix(IF,2)=rt(1,2)

        sfmix(IF,3)=rt(2,1)

        sfmix(IF,4)=rt(2,2)

  170 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYINOM

C...Finds the mass eigenstates and mixing matrices for neutralinos

C...and charginos.


      SUBROUTINE pyinom


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/


C...Local variables.

      DOUBLE PRECISION xmw,xmz

      DOUBLE PRECISION ar(4,4),wr(4),zr(4,4)

      DOUBLE PRECISION zp(4,4)

      DOUBLE PRECISION detx,xi(2,2)

      DOUBLE PRECISION xxx,yyy,xmh,xml

      DOUBLE PRECISION cosw,sinw

      DOUBLE PRECISION xmu

      DOUBLE PRECISION termb,termc,discr,xmh2,xml2

      DOUBLE PRECISION tanb,al,be,cosa,cosb,sina,sinb,xw

      DOUBLE PRECISION xm1,xm2,xm3,beta

      DOUBLE PRECISION q2,aem,a1,a2,a3,aq,rm1,rm2

      DOUBLE PRECISION arg,x0,x1,ax0,ax1,at,bt

      DOUBLE PRECISION y0,y1,amgx0,am1x0,amgx1,am1x1

      DOUBLE PRECISION argx0,ar1x0,argx1,ar1x1

      DOUBLE PRECISION pyalps,pyalem

      DOUBLE PRECISION pyrnm3

      INTEGER ierr,index(4),i,j,k,l,iopt,ilr,kfnchi(4)

      DATA kfnchi/1000022,1000023,1000025,1000035/


      iopt=imss(2)

      IF(imss(1).EQ.2) THEN

        iopt=1

      ENDIF

C...M1, M2, AND M3 ARE INDEPENDENT

      IF(iopt.EQ.0) THEN

        xm1=rmss(1)

        xm2=rmss(2)

        xm3=rmss(3)

      ELSEIF(iopt.GE.1) THEN

        q2=pmas(23,1)**2

        aem=pyalem(q2)

        a2=aem/paru(102)

        a1=aem/(1d0-paru(102))

        xm1=rmss(1)

        xm2=rmss(2)

        IF(imss(1).EQ.2) xm1=rmss(1)/rmss(20)*a1*5d0/3d0

        IF(iopt.EQ.1) THEN

          xm2=xm1*a2/a1*3d0/5d0

        ELSEIF(iopt.EQ.3) THEN

          xm1=xm2*5d0/3d0*a1/a2

        ENDIF

        xm3=pyrnm3(xm2/a2)

        IF(xm3.LE.0d0) THEN

          WRITE(mstu(11),*) ' ERROR WITH M3 = ',xm3

          stop

        ENDIF

      ENDIF


C...GLUINO MASS

      IF(imss(3).EQ.1) THEN

        pmas(pycomp(ksusy1+21),1)=xm3

      ELSE

        aq=0d0

        DO 110 i=1,4

          DO 100 ilr=1,2

            rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2

            aq=aq+0.5d0*((2d0-rm1)*(rm1*log(rm1)-1d0)

     &      +(1d0-rm1)**2*log(abs(1d0-rm1)))

  100     CONTINUE

  110   CONTINUE


        DO 130 i=5,6

          DO 120 ilr=1,2

            rm1=pmas(pycomp(ilr*ksusy1+i),1)**2/xm3**2

            rm2=pmas(i,1)**2/xm3**2

            arg=(rm1-rm2-1d0)**2-4d0*rm2**2

            IF(arg.GE.0d0) THEN

              x0=0.5d0*(1d0+rm2-rm1-sqrt(arg))

              ax0=abs(x0)

              x1=0.5d0*(1d0+rm2-rm1+sqrt(arg))

              ax1=abs(x1)

              IF(x0.EQ.1d0) THEN

                at=-1d0

                bt=0.25d0

              ELSEIF(x0.EQ.0d0) THEN

                at=0d0

                bt=-0.25d0

              ELSE

                at=0.5d0*log(abs(1d0-x0))*(1d0-x0**2)+

     &          0.5d0*x0**2*log(ax0)

                bt=(-1d0-2d0*x0)/4d0

              ENDIF

              IF(x1.EQ.1d0) THEN

                at=-1d0+at

                bt=0.25d0+bt

              ELSEIF(x1.EQ.0d0) THEN

                at=0d0+at

                bt=-0.25d0+bt

              ELSE

                at=0.5d0*log(abs(1d0-x1))*(1d0-x1**2)+0.5d0*

     &          x1**2*log(ax1)+at

                bt=(-1d0-2d0*x1)/4d0+bt

              ENDIF

              aq=aq+at+bt

            ELSE

              x0=0.5d0*(1d0+rm2-rm1)

              y0=-0.5d0*sqrt(-arg)

              amgx0=sqrt(x0**2+y0**2)

              am1x0=sqrt((1d0-x0)**2+y0**2)

              argx0=atan2(-x0,-y0)

              ar1x0=atan2(1d0-x0,y0)

              x1=x0

              y1=-y0

              amgx1=amgx0

              am1x1=am1x0

              argx1=atan2(-x1,-y1)

              ar1x1=atan2(1d0-x1,y1)

              at=0.5d0*log(am1x0)*(1d0-x0**2+3d0*y0**2)

     &        +0.5d0*(x0**2-y0**2)*log(amgx0)

              bt=(-1d0-2d0*x0)/4d0+x0*y0*( ar1x0-argx0 )

              at=at+0.5d0*log(am1x1)*(1d0-x1**2+3d0*y1**2)

     &        +0.5d0*(x1**2-y1**2)*log(amgx1)

              bt=bt+(-1d0-2d0*x1)/4d0+x1*y1*( ar1x1-argx1 )

              aq=aq+at+bt

            ENDIF

  120     CONTINUE

  130   CONTINUE

        pmas(pycomp(ksusy1+21),1)=xm3*(1d0+pyalps(xm3**2)/(2d0*paru(2))*

     &  (15d0+aq))

      ENDIF


C...NEUTRALINO MASSES

      xmz=pmas(23,1)

      xmw=pmas(24,1)

      xmu=rmss(4)

      sinw=sqrt(paru(102))

      cosw=sqrt(1d0-paru(102))

      tanb=rmss(5)

      beta=atan(tanb)

      cosb=cos(beta)

      sinb=tanb*cosb

      ar(1,1) = xm1

      ar(2,2) = xm2

      ar(3,3) = 0d0

      ar(4,4) = 0d0

      ar(1,2) = 0d0

      ar(2,1) = 0d0

      ar(1,3) = -xmz*sinw*cosb

      ar(3,1) = ar(1,3)

      ar(1,4) = xmz*sinw*sinb

      ar(4,1) = ar(1,4)

      ar(2,3) = xmz*cosw*cosb

      ar(3,2) = ar(2,3)

      ar(2,4) = -xmz*cosw*sinb

      ar(4,2) = ar(2,4)

      ar(3,4) = -xmu

      ar(4,3) = -xmu

      CALL pyeig4(ar,wr,zr)

      DO 150 i=1,4

        smz(i)=wr(i)

        pmas(pycomp(kfnchi(i)),1)=abs(smz(i))

        DO 140 j=1,4

          zmix(i,j)=zr(i,j)

          IF(abs(zmix(i,j)).LT.1d-6) zmix(i,j)=0d0

  140   CONTINUE

  150 CONTINUE


C...CHARGINO MASSES

      ar(1,1) = xm2

      ar(2,2) = xmu

      ar(1,2) = sqrt(2d0)*xmw*sinb

      ar(2,1) = sqrt(2d0)*xmw*cosb

      termb=ar(1,1)**2+ar(2,2)**2+ar(1,2)**2+ar(2,1)**2

      termc=(ar(1,1)**2-ar(2,2)**2)**2+(ar(1,2)**2-ar(2,1)**2)**2

      termc=termc+2d0*(ar(1,1)**2+ar(2,2)**2)*

     &(ar(1,2)**2+ar(2,1)**2)+

     &8d0*ar(1,1)*ar(2,2)*ar(1,2)*ar(2,1)

      discr=termc

      IF(discr.LT.0d0) THEN

        WRITE(mstu(11),*) ' PROBLEM WITH DISCR '

      ELSE

        discr=sqrt(discr)

      ENDIF

      xml2=0.5d0*(termb-discr)

      xmh2=0.5d0*(termb+discr)

      xml=sqrt(xml2)

      xmh=sqrt(xmh2)

      pmas(pycomp(ksusy1+24),1)=xml

      pmas(pycomp(ksusy1+37),1)=xmh

      smw(1)=xml

      smw(2)=xmh

      xxx=ar(1,1)**2+ar(2,1)**2

      yyy=ar(1,1)*ar(1,2)+ar(2,2)*ar(2,1)

      vmix(2,2) = yyy/sqrt(yyy**2+(xml2-xxx)**2)

      vmix(1,1) = sign(vmix(2,2),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)

      vmix(2,1) = -(xml2-xxx)/sqrt(yyy**2+(xml2-xxx)**2)

      vmix(1,2) = -sign(vmix(2,1),ar(1,1)*ar(2,2)-0.5d0*ar(1,2)**2)

      zr(1,1) = xml

      zr(1,2) = 0d0

      zr(2,1) = 0d0

      zr(2,2) = xmh

      detx = ar(1,1)*ar(2,2)-ar(1,2)*ar(2,1)

      xi(1,1) = ar(2,2)/detx

      xi(2,2) = ar(1,1)/detx

      xi(1,2) = -ar(1,2)/detx

      xi(2,1) = -ar(2,1)/detx

      DO 190 i=1,2

        DO 180 j=1,2

          umix(i,j)=0d0

          DO 170 k=1,2

            DO 160 l=1,2

              umix(i,j)=umix(i,j)+zr(i,k)*vmix(k,l)*xi(l,j)

  160       CONTINUE

  170     CONTINUE

  180   CONTINUE

  190 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYRNM3

C...Calculates the running of M3, the SU(3) gluino mass parameter.


      FUNCTION pyrnm3(RGUT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION pi,r

      DOUBLE PRECISION tol

      EXTERNAL pyalps

      DATA tol/0.001d0/

      DATA pi,r/3.141592654d0,0.61803399d0/


      c=1d0-r


      bx=rgut*pyalps(rgut**2)

      ax=min(50d0,bx*0.5d0)

      cx=max(2000d0,2d0*bx)


      x0=ax

      x3=cx

      IF(abs(cx-bx).GT.abs(bx-ax))THEN

        x1=bx

        x2=bx+c*(cx-bx)

      ELSE

        x2=bx

        x1=bx-c*(bx-ax)

      ENDIF

      as1=pyalps(x1**2)

      f1=abs(x1-rgut*as1)

      as2=pyalps(x2**2)

      f2=abs(x2-rgut*as2)

  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2))) THEN

        IF(f2.LT.f1) THEN

          x0=x1

          x1=x2

          x2=r*x1+c*x3

          f1=f2

          as2=pyalps(x2**2)

          f2=abs(x2-rgut*as2)

        ELSE

          x3=x2

          x2=x1

          x1=r*x2+c*x0

          f2=f1

          as1=pyalps(x1**2)

          f1=abs(x1-rgut*as1)

        ENDIF

        goto 100

      ENDIF

      IF(f1.LT.f2) THEN

        pyrnm3=x1

        xmin=x1

      ELSE

        pyrnm3=x2

        xmin=x2

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYEIG4

C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.

C...Specific application: mixing in neutralino sector.


      SUBROUTINE pyeig4(A,W,Z)

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Arrays: in call and local.

      dimension a(4,4),w(4),z(4,4),x(4),d(4,4),e(4)


C...Coefficients of fourth-degree equation from matrix.

C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.

      b3=-(a(1,1)+a(2,2)+a(3,3)+a(4,4))

      b2=0d0

      DO 110 i=1,3

        DO 100 j=i+1,4

          b2=b2+a(i,i)*a(j,j)-a(i,j)*a(j,i)

  100   CONTINUE

  110 CONTINUE

      b1=0d0

      b0=0d0

      DO 120 i=1,4

        i1=mod(i,4)+1

        i2=mod(i+1,4)+1

        i3=mod(i+2,4)+1

        b1=b1+a(i,i)*(-a(i1,i1)*a(i2,i2)+a(i1,i2)*a(i2,i1)+

     &  a(i1,i3)*a(i3,i1)+a(i2,i3)*a(i3,i2))-

     &  a(i,i1)*a(i1,i2)*a(i2,i)-a(i,i2)*a(i2,i1)*a(i1,i)

        b0=b0+(-1d0)**(i+1)*a(1,i)*(

     &  a(2,i1)*(a(3,i2)*a(4,i3)-a(3,i3)*a(4,i2))+

     &  a(2,i2)*(a(3,i3)*a(4,i1)-a(3,i1)*a(4,i3))+

     &  a(2,i3)*(a(3,i1)*a(4,i2)-a(3,i2)*a(4,i1)))

  120 CONTINUE


C...Coefficients of third-degree equation needed for

C...separation into two second-degree equations.

C...u**3 + c2 * u**2 + c1 * u + c0 = 0.

      c2=-b2

      c1=b1*b3-4d0*b0

      c0=-b1**2-b0*b3**2+4d0*b0*b2

      cq=c1/3d0-c2**2/9d0

      cr=c1*c2/6d0-c0/2d0-c2**3/27d0

      cqr=cq**3+cr**2


C...Cases with one or three real roots.

      IF(cqr.GE.0d0) THEN

        s1=(cr+sqrt(cqr))**(1d0/3d0)

        s2=(cr-sqrt(cqr))**(1d0/3d0)

        u=s1+s2-c2/3d0

      ELSE

        sabs=sqrt(-cq)

C        THE=ASIN(SQRT(CQR/CQ**3))/3D0

        the=acos(cr/sabs**3)/3d0

        sre=sabs*cos(the)

        u=2d0*sre-c2/3d0

      ENDIF


C...Find and solve two second-degree equations.

      p1=b3/2d0-sqrt(b3**2/4d0+u-b2)

      p2=b3/2d0+sqrt(b3**2/4d0+u-b2)

      q1=u/2d0+sqrt(u**2/4d0-b0)

      q2=u/2d0-sqrt(u**2/4d0-b0)

      x(1)=-p1/2d0+sqrt(p1**2/4d0-q1)

      x(2)=-p1/2d0-sqrt(p1**2/4d0-q1)

      x(3)=-p2/2d0+sqrt(p2**2/4d0-q2)

      x(4)=-p2/2d0-sqrt(p2**2/4d0-q2)


C...Order eigenvalues in asceding mass.

      w(1)=x(1)

      DO 150 i1=2,4

        DO 130 i2=i1-1,1,-1

          IF(abs(x(i1)).GE.abs(w(i2))) goto 140

          w(i2+1)=w(i2)

  130   CONTINUE

  140   w(i2+1)=x(i1)

  150 CONTINUE


C...Find equation system for eigenvectors.

      DO 250 i=1,4

        DO 170 j1=1,4

          d(j1,j1)=a(j1,j1)-w(i)

          DO 160 j2=j1+1,4

            d(j1,j2)=a(j1,j2)

            d(j2,j1)=a(j2,j1)

  160     CONTINUE

  170   CONTINUE


C...Find largest element in matrix.

        damax=0d0

        DO 190 j1=1,4

          DO 180 j2=1,4

            IF(abs(d(j1,j2)).LE.damax) goto 180

            ja=j1

            jb=j2

            damax=abs(d(j1,j2))

  180     CONTINUE

  190   CONTINUE


C...Subtract others by multiple of row selected above.

        damax=0d0

        DO 210 j3=ja+1,ja+3

          j1=j3-4*((j3-1)/4)

          rl=d(j1,jb)/d(ja,jb)

          DO 200 j2=1,4

            d(j1,j2)=d(j1,j2)-rl*d(ja,j2)

            IF(abs(d(j1,j2)).LE.damax) goto 200

            jc=j1

            jd=j2

            damax=abs(d(j1,j2))

  200     CONTINUE

  210   CONTINUE


C...Do one more subtraction of a row.

        damax=0d0

        DO 230 j3=jc+1,jc+3

          j1=j3-4*((j3-1)/4)

          IF(j1.EQ.ja) goto 230

          rl=d(j1,jd)/d(jc,jd)

          DO 220 j2=1,4

            IF(j2.EQ.jb) goto 220

            d(j1,j2)=d(j1,j2)-rl*d(jc,j2)

            IF(abs(d(j1,j2)).LE.damax) goto 220

            je=j1

            damax=abs(d(j1,j2))

  220     CONTINUE

  230   CONTINUE


C...Construct unnormalized eigenvector.

        jf1=jd+1-4*(jd/4)

        jf2=jd+2-4*((jd+1)/4)

        IF(jf1.EQ.jb) jf1=jd+3-4*((jd+2)/4)

        IF(jf2.EQ.jb) jf2=jd+3-4*((jd+2)/4)

        e(jf1)=-d(je,jf2)

        e(jf2)=d(je,jf1)

        e(jd)=-(d(jc,jf1)*e(jf1)+d(jc,jf2)*e(jf2))/d(jc,jd)

        e(jb)=-(d(ja,jf1)*e(jf1)+d(ja,jf2)*e(jf2)+d(ja,jd)*e(jd))/

     &  d(ja,jb)


C...Normalize and fill in final array.

        ea=sqrt(e(1)**2+e(2)**2+e(3)**2+e(4)**2)

        sgn=(-1d0)**int(pyr(0)+0.5d0)

        DO 240 j=1,4

          z(i,j)=sgn*e(j)/ea

  240   CONTINUE

  250 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYHGGM

C...Determines the Higgs boson mass spectrum using several inputs.


      SUBROUTINE pyhggm(ALPHA)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/


C...Local variables.

      DOUBLE PRECISION at,ab,xmu,tanb,xm32,xmt2

      DOUBLE PRECISION alpha

      INTEGER i,j,ihopt,ii,jj,it

      DOUBLE PRECISION dma,dtanb,dmq,dmur,dmtop,dau,dad

      DOUBLE PRECISION dmu,dmh,dhm,dmhch,dsa,dca,dtanba

      DOUBLE PRECISION dmc,dmdr,dmhp,dhmp,damp

      DOUBLE PRECISION dstop1,dstop2,dsbot1,dsbot2


      ihopt=imss(4)

      IF(ihopt.EQ.2) THEN

        alpha=rmss(18)

        RETURN

      ENDIF

      at=rmss(16)

      ab=rmss(15)

      xmu=rmss(4)

      tanb=rmss(5)


      dma=rmss(19)

      dtanb=tanb

      dmq=rmss(10)

      dmur=rmss(12)

      dmdr=rmss(11)

      dmtop=pmas(6,1)

      dmc=pmas(pycomp(ksusy1+37),1)

      dau=at

      dad=ab

      dmu=xmu


      IF(ihopt.EQ.0) THEN

        CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,

     &  dmhch,dsa,dca,dtanba)

      ELSEIF(ihopt.EQ.1) THEN

        CALL pysubh(dma,dtanb,dmq,dmur,dmtop,dau,dad,dmu,dmh,dhm,

     &  dmhch,dsa,dca,dtanba)

        CALL pypole(3,dmc,dma,dtanb,dmq,dmur,dmdr,dmtop,dau,dad,dmu,

     &  dmh,dmhp,dhm,dhmp,damp,dsa,dca,

     &  dstop1,dstop2,dsbot1,dsbot2,dtanba)

        dmh=dmhp

        dhm=dhmp

        dma=damp

      ENDIF


      alpha=acos(dca)


      pmas(25,1)=dmh

      pmas(35,1)=dhm

      pmas(36,1)=dma

      pmas(37,1)=dmhch


      RETURN

      END


C*********************************************************************


C...PYSUBH

C...This routine computes the renormalization group improved

C...values of Higgs masses and couplings in the MSSM.


C...Program based on the work by M. Carena, J.R. Espinosa,

c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45


C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU

C...All masses in GeV units. MA is the CP-odd Higgs mass,

C...MTOP is the physical top mass, MQ and MUR are the soft

C...supersymmetry breaking mass parameters of left handed

C...and right handed stops respectively, AU and AD are the

C...stop and sbottom trilinear soft breaking terms,

C...respectively,  and MU is the supersymmetric

C...Higgs mass parameter. We use the  conventions from

C...the physics report of Haber and Kane: left right

C...stop mixing term proportional to (AU - MU/TANB)

C...We use as input TANB defined at the scale MTOP


C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA

C...where MH and HM are the lightest and heaviest CP-even

C...Higgs masses, MHCH is the charged Higgs mass and

C...ALPHA is the Higgs mixing angle

C...TANBA is the angle TANB at the CP-odd Higgs mass scale


C...Range of validity:

C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5

C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5

C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and

C...are the sbottom  mass eigenvalues, respectively. This

C...range automatically excludes the existence of tachyons.

C...For the charged Higgs mass computation, the method is

C...valid if

C...2 * |MB * AD* TANB|  < M_SUSY**2,  2 * |MTOP * AU| < M_SUSY**2

C...2 * |MB * MU * TANB| < M_SUSY**2,  2 * |MTOP * MU| < M_SUSY**2

C...where M_SUSY**2 is the average of the squared stop mass

C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom

C...masses have been assumed to be of order of the stop ones

C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2


      SUBROUTINE pysubh (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,

     &xmhch,sa,ca,tanba)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Local variables.

      DOUBLE PRECISION pyalem,pyalps

      DOUBLE PRECISION tanb,xmq,xmur,xmtop,au,ad,xmu,xmh,xhm

      DOUBLE PRECISION xmhch,sa,ca

      DOUBLE PRECISION xma,aem,alp1,alp2,alph3z,v,pi

      DOUBLE PRECISION q02

      DOUBLE PRECISION tanba,tanbt,xmb,alp3

      DOUBLE PRECISION rmtop,xms,t,sinb,cosb

      DOUBLE PRECISION xlam1,xlam2,xlam3,xlam4,xlam5,xlam6

      DOUBLE PRECISION xlam7,xau,xad,g1,g2,g3,hu,hd,hu2

      DOUBLE PRECISION hd2,hu4,hd4,sinbt,cosbt

      DOUBLE PRECISION trm2,detm2,xmh2,xhm2,xmhch2

      DOUBLE PRECISION sinalp,cosalp,aud,pi2,xms2,xms4,ad2

      DOUBLE PRECISION cos2bt,au2,xmu2,xmz,xms3


      xmz = pmas(23,1)

      q02=xmz**2

      aem=pyalem(q02)

      alp1=aem/(1d0-paru(102))

      alp2=aem/paru(102)

      alph3z=pyalps(q02)


      alp1 = 0.0101d0

      alp2 = 0.0337d0

      alph3z = 0.12d0


      v = 174.1d0

      pi = paru(1)

      tanba = tanb

      tanbt = tanb


C...MBOTTOM(MTOP) = 3. GEV

      xmb = 3d0

      alp3 = alph3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alph3z*

     &log(xmtop**2/xmz**2))


C...RMTOP= RUNNING TOP QUARK MASS

      rmtop = xmtop/(1d0+4d0*alp3/3d0/pi)

      xms = ((xmq**2 + xmur**2)/2d0 + xmtop**2)**0.5d0

      t = log(xms**2/xmtop**2)

      sinb = tanb/((1d0 + tanb**2)**0.5d0)

      cosb = sinb/tanb

C...IF(MA.LE.XMTOP) TANBA = TANBT

      IF(xma.GT.xmtop)

     &tanba = tanbt*(1d0-3d0/32d0/pi**2*

     &(rmtop**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*

     &log(xma**2/xmtop**2))


      sinbt = tanbt/sqrt(1d0 + tanbt**2)

      cosbt = 1d0/sqrt(1d0 + tanbt**2)

      cos2bt = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)

      g1 = sqrt(alp1*4d0*pi)

      g2 = sqrt(alp2*4d0*pi)

      g3 = sqrt(alp3*4d0*pi)

      hu = rmtop/v/sinbt

      hd =  xmb/v/cosbt

      hu2=hu*hu

      hd2=hd*hd

      hu4=hu2*hu2

      hd4=hd2*hd2

      au2=au**2

      ad2=ad**2

      xms2=xms**2

      xms3=xms**3

      xms4=xms2*xms2

      xmu2=xmu*xmu

      pi2=pi*pi


      xau = (2d0*au2/xms2)*(1d0 - au2/12d0/xms2)

      xad = (2d0*ad2/xms2)*(1d0 - ad2/12d0/xms2)

      aud = (-6d0*xmu2/xms2 - ( xmu2- ad*au)**2/xms4

     &+ 3d0*(au + ad)**2/xms2)/6d0

      xlam1 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hd2*t/8d0/pi2)

     &+(3d0*hd4/8d0/pi2) * (t + xad/2d0 + (3d0*hd2/2d0 + hu2/2d0

     &- 8d0*g3**2) * (xad*t + t**2)/16d0/pi2)

     &-(3d0*hu4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hu2 -5d0* hd2

     &-  16d0*g3**2) *t/16d0/pi2)

      xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu2*t/8d0/pi2)

     &+(3d0*hu4/8d0/pi2) * (t + xau/2d0 + (3d0*hu2/2d0 + hd2/2d0

     &- 8d0*g3**2) * (xau*t + t**2)/16d0/pi2)

     &-(3d0*hd4* xmu**4/96d0/pi2/xms4) * (1+ (9d0*hd2 -5d0* hu2

     &-  16d0*g3**2) *t/16d0/pi2)

      xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*

     &(hu2 + hd2)*t/16d0/pi2)

     &+(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2

     &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)

     &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/

     &xms4)* (1d0+ (6d0*hu2 -2d0* hd2/2d0

     &-  16d0*g3**2) *t/16d0/pi2)

     &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/

     &xms4)*(1d0+ (6d0*hd2 -2d0* hu2

     &-  16d0*g3**2) *t/16d0/pi2)

      xlam4 = (- g2**2/2d0)*(1d0-3d0*(hu2 + hd2)*t/16d0/pi2)

     &-(6d0*hu2*hd2/16d0/pi2) * (t + aud/2d0 + (hu2 + hd2

     &- 8d0*g3**2) * (aud*t + t**2)/16d0/pi2)

     &+(3d0*hu4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*au2/

     &xms4)*

     &(1+ (6d0*hu2 -2d0* hd2

     &-  16d0*g3**2) *t/16d0/pi2)

     &+(3d0*hd4/96d0/pi2) * (3d0*xmu2/xms2 - xmu2*ad2/

     &xms4)*

     &(1+ (6d0*hd2 -2d0* hu2/2d0

     &-  16d0*g3**2) *t/16d0/pi2)

      xlam5 = -(3d0*hu4* xmu2*au2/96d0/pi2/xms4) *

     &(1- (2d0*hd2 -6d0* hu2 + 16d0*g3**2) *t/16d0/pi2)

     &-(3d0*hd4* xmu2*ad2/96d0/pi2/xms4) *

     &(1- (2d0*hu2 -6d0* hd2 + 16d0*g3**2) *t/16d0/pi2)

      xlam6 = (3d0*hu4* xmu**3*au/96d0/pi2/xms4) *

     &(1- (7d0*hd2/2d0 -15d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)

     &+(3d0*hd4* xmu *(ad**3/xms3 - 6d0*ad/xms )/96d0/pi2/xms) *

     &(1- (hu2/2d0 -9d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)

      xlam7 = (3d0*hd4* xmu**3*ad/96d0/pi2/xms4) *

     &(1- (7d0*hu2/2d0 -15d0* hd2/2d0 + 16d0*g3**2) *t/16d0/pi2)

     &+(3d0*hu4* xmu *(au**3/xms3 - 6d0*au/xms )/96d0/pi2/xms) *

     &(1- (hd2/2d0 -9d0* hu2/2d0 + 16d0*g3**2) *t/16d0/pi2)

      trm2 = xma**2 + 2d0*v**2* (xlam1* cosbt**2 +

     &2d0* xlam6*sinbt*cosbt

     &+ xlam5*sinbt**2 + xlam2* sinbt**2 + 2d0* xlam7*sinbt*cosbt

     &+ xlam5*cosbt**2)

      detm2 = 4d0*v**4*(-(sinbt*cosbt*(xlam3 + xlam4) +

     &xlam6*cosbt**2

     &+ xlam7* sinbt**2)**2 + (xlam1* cosbt**2 +

     &2d0* xlam6* cosbt*sinbt

     &+ xlam5*sinbt**2)*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt

     &+ xlam5*cosbt**2)) + xma**2*2d0*v**2 *

     &((xlam1* cosbt**2 +2d0*

     &xlam6* cosbt*sinbt + xlam5*sinbt**2)*cosbt**2 +

     &(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt + xlam5*cosbt**2)

     &*sinbt**2

     &+2d0*sinbt*cosbt* (sinbt*cosbt*(xlam3

     &+ xlam4) + xlam6*cosbt**2

     &+ xlam7* sinbt**2))


      xmh2 = (trm2 - sqrt(trm2**2 - 4d0* detm2))/2d0

      xhm2 = (trm2 + sqrt(trm2**2 - 4d0* detm2))/2d0

      xhm = sqrt(xhm2)

      xmh = sqrt(xmh2)

      xmhch2 = xma**2 + (xlam5 - xlam4)* v**2

      xmhch = sqrt(xmhch2)


      sinalp = sqrt(((trm2**2 - 4d0* detm2)**0.5d0) -

     &((2d0*v**2*(xlam1* cosbt**2 + 2d0*

     &xlam6* cosbt*sinbt

     &+ xlam5*sinbt**2) + xma**2*sinbt**2)

     &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt

     &+ xlam5*cosbt**2) + xma**2*cosbt**2)))/

     &sqrt(((trm2**2 - 4d0* detm2)**0.5d0))/2d0**0.5d0


      cosalp = (2d0*(2d0*v**2*(sinbt*cosbt*(xlam3 + xlam4) +

     &xlam6*cosbt**2 + xlam7* sinbt**2) -

     &xma**2*sinbt*cosbt))/2d0**0.5d0/

     &sqrt(((trm2**2 - 4d0* detm2)**0.5d0)*

     &(((trm2**2 - 4d0* detm2)**0.5d0) -

     &((2d0*v**2*(xlam1* cosbt**2 + 2d0*

     &xlam6* cosbt*sinbt

     &+ xlam5*sinbt**2) + xma**2*sinbt**2)

     &- (2d0*v**2*(xlam2* sinbt**2 +2d0* xlam7* cosbt*sinbt

     &+ xlam5*cosbt**2) + xma**2*cosbt**2))))


      sa = -sinalp

      ca = -cosalp


  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYPOLE

C...This subroutine computes the CP-even higgs and CP-odd pole

c...Higgs masses and mixing angles.


C...Program based on the work by M. Carena, M. Quiros

C...and C.E.M. Wagner, "Effective potential methods and

C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157


C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,

C...AT,AB,MU

C...where MCHI is the largest chargino mass, MA is the running

C...CP-odd higgs mass, TANB is the value of the ratio of vacuum

C...expectaion values at the scale MTOP, MQ is the third generation

C...left handed squark mass parameter, MUR is the third generation

C...right handed stop mass parameter, MDR is the third generation

C...right handed sbottom mass parameter, MTOP is the pole top quark

C...mass; AT,AB are the soft supersymmetry breaking trilinear

C...couplings of the stop and sbottoms, respectively, and MU is the

C...supersymmetric mass parameter


C...The parameter IHIGGS=0,1,2,3 corresponds to the

c...number of Higgses whose pole mass is computed

c...by the subroutine PYVACU(...). If IHIGGS=0 only running

c...masses are given, what makes the running of the program

c...much faster and it is quite generally a good approximation

c...(for a theoretical discussion see ref. below).

c...If IHIGGS=1, only the pole

c...mass for H is computed. If IHIGGS=2, then h and H, and

c...if IHIGGS=3, then h,H,A polarizations are computed


C...Output: MH and MHP which are the lightest CP-even Higgs running

C...and pole masses, respectively; HM and HMP are the heaviest CP-even

C...Higgs running and pole masses, repectively; SA and CA are the

C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle

C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2

C...are the stop and sbottom mass eigenvalues. Finally, TANBA is

C...the value of TANB at the CP-odd Higgs mass scale


C...This subroutine makes use of CERN library subroutine

C...integration package, which makes the computation of the

C...pole Higgs masses somewhat faster. We thank P. Janot for this

C...improvement. Those who are not able to call the CERN

C...libraries, please use the subroutine SUBHPOLE2.F, which

C...although somewhat slower, gives identical results


      SUBROUTINE pypole(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,

     &xmh,xmhp,hm,hmp,amp,sa,ca,stop1,stop2,sbot1,sbot2,tanba)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


      CALL pyvacu(ihiggs,xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,xmu,

     &xmh,xmhp,hm,hmp,amp,stop1,stop2,sbot1,sbot2,

     &sa,ca,stop1w,stop2w,tanba)

      sinb = tanb/(tanb**2+1d0)**0.5d0

      cosb = 1d0/(tanb**2+1d0)**0.5d0

      sinbma = sinb*ca - cosb*sa


      RETURN

      END


C*********************************************************************


C...PYVACU

C...Computes Higgs masses and mixing angles, see PYPOLE above.


      SUBROUTINE pyvacu(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,

     &xmt,at,ab,xmu,xmh,xmhp,hm,hmp,amp,stop1,stop2,

     &sbot1,sbot2,sa,ca,stop1w,stop2w,tanba)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      dimension delta(2,2),coupt(2,2),t(2,2),sstop2(2),

     &ssbot2(2),b(2,2),coupb(2,2),

     &hcoupt(2,2),hcoupb(2,2),

     &acoupt(2,2),acoupb(2,2),pr(3), polar(3)


      delta(1,1) = 1d0

      delta(2,2) = 1d0

      delta(1,2) = 0d0

      delta(2,1) = 0d0

      v = 174.1d0

      xmz=91.18d0

      pi=3.14159d0

      alp3z=0.12d0

      alp3=1d0/(1d0/alp3z+23d0/6d0/pi*log(xmt/xmz))


      rxmt = xmt/(1d0+4*alp3/3d0/pi)


      ht = rxmt /v

      CALL pyrghm(xmc,xma,tanb,xmq,xmur,xmdr,xmt,at,ab,

     &xmu,xmh,hm,sa,ca,tanba)

      sinb = tanb/(tanb**2+1d0)**0.5d0

      cosb = 1d0/(tanb**2+1d0)**0.5d0

      cos2b = sinb**2 - cosb**2

      sinbpa = sinb*ca + cosb*sa

      cosbpa = cosb*ca - sinb*sa

      rmbot = 3d0

      xmq2 = xmq**2

      xmur2 = xmur**2

      xmdr2 = xmdr**2

      xmst11 = rxmt**2 + xmq2  - 0.35d0*xmz**2*cos2b

      xmst22 = rxmt**2 + xmur2 - 0.15d0*xmz**2*cos2b

      IF(xmst11.LT.0d0) goto 500

      IF(xmst22.LT.0d0) goto 500

      xmsb11 = rmbot**2 + xmq2  + 0.42d0*xmz**2*cos2b

      xmsb22 = rmbot**2 + xmdr2 + 0.08d0*xmz**2*cos2b

      IF(xmsb11.LT.0d0) goto 500

      IF(xmsb22.LT.0d0) goto 500

      wmst11 = rxmt**2 + xmq2

      wmst22 = rxmt**2 + xmur2

      xmst12 = rxmt*(at - xmu/tanb)

      xmsb12 = rmbot*(ab - xmu*tanb)


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...STOP EIGENVALUES CALCULATION

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      stop12 = 0.5d0*(xmst11+xmst22) +

     &0.5d0*((xmst11+xmst22)**2 -

     &4d0*(xmst11*xmst22 - xmst12**2))**0.5d0

      stop22 = 0.5d0*(xmst11+xmst22) -

     &0.5d0*((xmst11+xmst22)**2 - 4d0*(xmst11*xmst22 -

     &xmst12**2))**0.5d0

      IF(stop22.LT.0d0) goto 500

      sstop2(1) = stop12

      sstop2(2) = stop22

      stop1 = stop12**0.5d0

      stop2 = stop22**0.5d0

      stop1w = stop1

      stop2w = stop2


      IF(xmst12.EQ.0d0) xst11 = 1d0

      IF(xmst12.EQ.0d0) xst12 = 0d0

      IF(xmst12.EQ.0d0) xst21 = 0d0

      IF(xmst12.EQ.0d0) xst22 = 1d0


      IF(xmst12.EQ.0d0) goto 110


  100 xst11 = xmst12/(xmst12**2+(xmst11-stop12)**2)**0.5d0

      xst12 = - (xmst11-stop12)/(xmst12**2+(xmst11-stop12)**2)**0.5d0

      xst21 = xmst12/(xmst12**2+(xmst11-stop22)**2)**0.5d0

      xst22 = - (xmst11-stop22)/(xmst12**2+(xmst11-stop22)**2)**0.5d0


  110 t(1,1) = xst11

      t(2,2) = xst22

      t(1,2) = xst12

      t(2,1) = xst21


      sbot12 = 0.5d0*(xmsb11+xmsb22) +

     &0.5d0*((xmsb11+xmsb22)**2 -

     &4d0*(xmsb11*xmsb22 - xmsb12**2))**0.5d0

      sbot22 = 0.5d0*(xmsb11+xmsb22) -

     &0.5d0*((xmsb11+xmsb22)**2 - 4d0*(xmsb11*xmsb22 -

     &xmsb12**2))**0.5d0

      IF(sbot22.LT.0d0) goto 500

      sbot1 = sbot12**0.5d0

      sbot2 = sbot22**0.5d0

      ssbot2(1) = sbot12

      ssbot2(2) = sbot22


      IF(xmsb12.EQ.0d0) xsb11 = 1d0

      IF(xmsb12.EQ.0d0) xsb12 = 0d0

      IF(xmsb12.EQ.0d0) xsb21 = 0d0

      IF(xmsb12.EQ.0d0) xsb22 = 1d0


      IF(xmsb12.EQ.0d0) goto 130


  120 xsb11 = xmsb12/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0

      xsb12 = - (xmsb11-sbot12)/(xmsb12**2+(xmsb11-sbot12)**2)**0.5d0

      xsb21 = xmsb12/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0

      xsb22 = - (xmsb11-sbot22)/(xmsb12**2+(xmsb11-sbot22)**2)**0.5d0


  130 b(1,1) = xsb11

      b(2,2) = xsb22

      b(1,2) = xsb12

      b(2,1) = xsb21


      sint = 0.2320d0

      sqr = 2d0**0.5d0

      vp = 174.1d0*sqr


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...STARTING OF LIGHT HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      IF(ihiggs.EQ.0) goto 490


      DO 150 i = 1,2

        DO 140 j = 1,2

          coupt(i,j) =

     &    sint*xmz**2*2d0*sqr/174.1d0/3d0*sinbpa*(delta(i,j) +

     &    (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))

     &    -rxmt**2/174.1d0**2*vp/sinb*ca*delta(i,j)

     &    -rxmt/vp/sinb*(at*ca + xmu*sa)*(t(1,i)*t(2,j) +

     &    t(1,j)*t(2,i))

  140   CONTINUE

  150 CONTINUE


      DO 170 i = 1,2

        DO 160 j = 1,2

          coupb(i,j) =

     &    -sint*xmz**2*2d0*sqr/174.1d0/6d0*sinbpa*(delta(i,j) +

     &    (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))

     &    +rmbot**2/174.1d0**2*vp/cosb*sa*delta(i,j)

     &    +rmbot/vp/cosb*(ab*sa + xmu*ca)*(b(1,i)*b(2,j) +

     &    b(1,j)*b(2,i))

  160   CONTINUE

  170 CONTINUE


      prun = xmh

      eps = 1d-4*prun

      iter = 0

  180 iter = iter + 1

      DO 230  i3 = 1,3


        pr(i3)=prun+(i3-2)*eps/2

        p2=pr(i3)**2

        polt = 0d0

        DO 200 i = 1,2

          DO 190 j = 1,2

            polt = polt + coupt(i,j)**2*3d0*

     &      pyfint(p2,sstop2(i),sstop2(j))/16d0/pi**2

  190     CONTINUE

  200   CONTINUE

        polb = 0d0

        DO 220 i = 1,2

          DO 210 j = 1,2

            polb = polb + coupb(i,j)**2*3d0*

     &      pyfint(p2,ssbot2(i),ssbot2(j))/16d0/pi**2

  210     CONTINUE

  220   CONTINUE

        rxmt2 = rxmt**2

        xmt2=xmt**2


        poltt =

     &  3d0*rxmt**2/8d0/pi**2/  v  **2*

     &  ca**2/sinb**2 *

     &  (-2d0*xmt**2+0.5d0*p2)*

     &  pyfint(p2,xmt2,xmt2)


        pol = polt + polb + poltt

        polar(i3) = p2 - xmh**2 - pol

  230 CONTINUE

      deriv = (polar(3)-polar(1))/eps

      drun = - polar(2)/deriv

      prun = prun + drun

      p2 = prun**2

      IF( abs(drun) .LT. 1d-4 ) goto 240

      goto 180

  240 CONTINUE


      xmhp = p2**0.5d0


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...END OF LIGHT HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


  250 IF(ihiggs.EQ.1) goto 490


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C... STARTING OF HEAVY HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      DO 270 i = 1,2

        DO 260 j = 1,2

          hcoupt(i,j) =

     &    -sint*xmz**2*2d0*sqr/174.1d0/3d0*cosbpa*(delta(i,j) +

     &    (3d0 - 8d0*sint)/4d0/sint*t(1,i)*t(1,j))

     &    -rxmt**2/174.1d0**2*vp/sinb*sa*delta(i,j)

     &    -rxmt/vp/sinb*(at*sa - xmu*ca)*(t(1,i)*t(2,j) +

     &    t(1,j)*t(2,i))

  260   CONTINUE

  270 CONTINUE


      DO 290 i = 1,2

        DO 280 j = 1,2

          hcoupb(i,j) =

     &    sint*xmz**2*2d0*sqr/174.1d0/6d0*cosbpa*(delta(i,j) +

     &    (3d0 - 4d0*sint)/2d0/sint*b(1,i)*b(1,j))

     &    -rmbot**2/174.1d0**2*vp/cosb*ca*delta(i,j)

     &    -rmbot/vp/cosb*(ab*ca - xmu*sa)*(b(1,i)*b(2,j) +

     &    b(1,j)*b(2,i))

          hcoupb(i,j)=0d0

  280   CONTINUE

  290 CONTINUE


      prun = hm

      eps = 1d-4*prun

      iter = 0

  300 iter = iter + 1

      DO 350 i3 = 1,3

        pr(i3)=prun+(i3-2)*eps/2

        hp2=pr(i3)**2


        hpolt = 0d0

        DO 320 i = 1,2

          DO 310 j = 1,2

            hpolt = hpolt + hcoupt(i,j)**2*3d0*

     &      pyfint(hp2,sstop2(i),sstop2(j))/16d0/pi**2

  310     CONTINUE

  320   CONTINUE


        hpolb = 0d0

        DO 340 i = 1,2

          DO 330 j = 1,2

            hpolb = hpolb + hcoupb(i,j)**2*3d0*

     &      pyfint(hp2,ssbot2(i),ssbot2(j))/16d0/pi**2

  330     CONTINUE

  340   CONTINUE


        rxmt2 = rxmt**2

        xmt2  = xmt**2


        hpoltt =

     &  3d0*rxmt**2/8d0/pi**2/  v  **2*

     &  sa**2/sinb**2 *

     &  (-2d0*xmt**2+0.5d0*hp2)*

     &  pyfint(hp2,xmt2,xmt2)


        hpol = hpolt + hpolb + hpoltt

        polar(i3) =hp2-hm**2-hpol

  350 CONTINUE

      deriv = (polar(3)-polar(1))/eps

      drun = - polar(2)/deriv

      prun = prun + drun

      hp2 = prun**2

      IF( abs(drun) .LT. 1d-4 ) goto 360

      goto 300

  360 CONTINUE


  370 CONTINUE

      hmp = hp2**0.5d0


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C... END OF HEAVY HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      IF(ihiggs.EQ.2) goto 490


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...BEGINNING OF PSEUDOSCALAR HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      DO 390 i = 1,2

        DO 380 j = 1,2

          acoupt(i,j) =

     &    -rxmt/vp/sinb*(at*cosb + xmu*sinb)*

     &    (t(1,i)*t(2,j) -t(1,j)*t(2,i))

  380   CONTINUE

  390 CONTINUE

      DO 410 i = 1,2

        DO 400 j = 1,2

          acoupb(i,j) =

     &    rmbot/vp/cosb*(ab*sinb + xmu*cosb)*

     &    (b(1,i)*b(2,j) -b(1,j)*b(2,i))

  400   CONTINUE

  410 CONTINUE


      prun = xma

      eps = 1d-4*prun

      iter = 0

  420 iter = iter + 1

      DO 470 i3 = 1,3

        pr(i3)=prun+(i3-2)*eps/2

        ap2=pr(i3)**2

        apolt = 0d0

        DO 440 i = 1,2

          DO 430 j = 1,2

            apolt = apolt + acoupt(i,j)**2*3d0*

     &      pyfint(ap2,sstop2(i),sstop2(j))/16d0/pi**2

  430     CONTINUE

  440   CONTINUE

        apolb = 0d0

        DO 460 i = 1,2

          DO 450 j = 1,2

            apolb = apolb + acoupb(i,j)**2*3d0*

     &      pyfint(ap2,ssbot2(i),ssbot2(j))/16d0/pi**2

  450     CONTINUE

  460   CONTINUE

        rxmt2 = rxmt**2

        xmt2=xmt**2

        apoltt =

     &  3d0*rxmt**2/8d0/pi**2/  v  **2*

     &  cosb**2/sinb**2 *

     &  (-0.5d0*ap2)*

     &  pyfint(ap2,xmt2,xmt2)

        apol = apolt + apolb + apoltt

        polar(i3) = ap2 - xma**2 -apol

  470 CONTINUE

      deriv = (polar(3)-polar(1))/eps

      drun = - polar(2)/deriv

      prun = prun + drun

      ap2 = prun**2

      IF( abs(drun) .LT. 1d-4 ) goto 480

      goto 420

  480 CONTINUE


      amp = ap2**0.5d0


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...END OF PSEUDOSCALAR HIGGS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      IF(ihiggs.EQ.3) goto 490


  490 CONTINUE

      RETURN

  500 CONTINUE

      stop

      END


C*********************************************************************


C...PYRGHM

C...Auxiliary routine to PYVACU for SUSY Higgs calculations.


      SUBROUTINE pyrghm(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU,

     &xmhp,hmp,sa,ca,tanba)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      dimension vh(2,2),xm2(2,2),xm2p(2,2)


      xmz = 91.18d0

      alp1 = 0.0101d0

      alp2 = 0.0337d0

      alp3z = 0.12d0

      v = 174.1d0

      pi = 3.14159d0

      tanba = tanb

      tanbt = tanb


C...MBOTTOM(XMT) = 3. GEV

      xmb = 3d0

      alp3 = alp3z/(1d0 +(11d0 - 10d0/3d0)/4d0/pi*alp3z*

     &log(xmt**2/xmz**2))


C...RXMT= RUNNING TOP QUARK MASS

      rxmt = xmt/(1d0+4d0*alp3/3d0/pi)

      tq = log((xmq**2+xmt**2)/xmt**2)

      tu = log((xmur**2 + xmt**2)/xmt**2)

      td = log((xmdl**2 + xmt**2)/xmt**2)

      sinb = tanb/((1d0 + tanb**2)**0.5d0)

      cosb = sinb/tanb

      IF(xma.GT.xmt)

     &tanba = tanb*(1d0-3d0/32d0/pi**2*

     &(rxmt**2/v**2/sinb**2-xmb**2/v**2/cosb**2)*

     &log(xma**2/xmt**2))

      IF(xma.LT.xmt.OR.xma.EQ.xmt) tanbt = tanba

      sinb = tanbt/((1d0 + tanbt**2)**0.5d0)

      cosb = 1d0/((1d0 + tanbt**2)**0.5d0)

      cos2b = (tanbt**2 - 1d0)/(tanbt**2 + 1d0)

      g1 = (alp1*4d0*pi)**0.5d0

      g2 = (alp2*4d0*pi)**0.5d0

      g3 = (alp3*4d0*pi)**0.5d0

      hu = rxmt/v/sinb

      hd =  xmb/v/cosb


      CALL pygfxx(xma,tanba,xmq,xmur,xmdl,xmt,au,ad,

     &xmu,vh,stop1,stop2)


      IF(xmq.GT.xmur) tp = tq - tu

      IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tp = tu - tq

      IF(xmq.GT.xmur) tdp = tu

      IF(xmq.LT.xmur.OR.xmq.EQ.xmur) tdp = tq

      IF(xmq.GT.xmdl) tpd = tq - td

      IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tpd = td - tq

      IF(xmq.GT.xmdl) tdpd = td

      IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) tdpd = tq


      IF(xmq.GT.xmdl) dlam1 = 6d0/96d0/pi**2*g1**2*hd**2*tpd

      IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam1 = 3d0/32d0/pi**2*

     &hd**2*(g1**2/3d0+g2**2)*tpd


      IF(xmq.GT.xmur) dlam2 =12d0/96d0/pi**2*g1**2*hu**2*tp

      IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam2 = 3d0/32d0/pi**2*

     &hu**2*(-g1**2/3d0+g2**2)*tp


      dlam3 = 0d0

      dlam4 = 0d0


      IF(xmq.GT.xmdl) dlam3 = -1d0/32d0/pi**2*g1**2*hd**2*tpd

      IF(xmq.LT.xmdl.OR.xmq.EQ.xmdl) dlam3 = 3d0/64d0/pi**2*hd**2*

     &(g2**2-g1**2/3d0)*tpd


      IF(xmq.GT.xmur) dlam3 = dlam3 -

     &1d0/16d0/pi**2*g1**2*hu**2*tp

      IF(xmq.LT.xmur.OR.xmq.EQ.xmur) dlam3 = dlam3 +

     &3d0/64d0/pi**2*hu**2*(g2**2+g1**2/3d0)*tp


      IF(xmq.LT.xmur) dlam4 = -3d0/32d0/pi**2*g2**2*hu**2*tp

      IF(xmq.LT.xmdl) dlam4 = dlam4 - 3d0/32d0/pi**2*g2**2*

     &hd**2*tpd


      xlam1 = ((g1**2 + g2**2)/4d0)*

     &(1d0-3d0*hd**2*(tpd + tdpd)/8d0/pi**2)

     &+(3d0*hd**4/16d0/pi**2) *tpd*(1d0

     &+ (3d0*hd**2/2d0 + hu**2/2d0

     &- 8d0*g3**2) * (tpd + 2d0*tdpd)/16d0/pi**2)

     &+(3d0*hd**4/8d0/pi**2) *tdpd*(1d0  + (3d0*hd**2/2d0 + hu**2/2d0

     &- 8d0*g3**2) * tdpd/16d0/pi**2) + dlam1

      xlam2 = ((g1**2 + g2**2)/4d0)*(1d0-3d0*hu**2*

     &(tp + tdp)/8d0/pi**2)

     &+(3d0*hu**4/16d0/pi**2) *tp*(1d0

     &+ (3d0*hu**2/2d0 + hd**2/2d0

     &- 8d0*g3**2) * (tp + 2d0*tdp)/16d0/pi**2)

     &+(3d0*hu**4/8d0/pi**2) *tdp*(1d0 + (3d0*hu**2/2d0 + hd**2/2d0

     &- 8d0*g3**2) * tdp/16d0/pi**2) + dlam2

      xlam3 = ((g2**2 - g1**2)/4d0)*(1d0-3d0*

     &(hu**2)*(tp + tdp)/16d0/pi**2 -3d0*

     &(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam3

      xlam4 = (- g2**2/2d0)*(1d0

     &-3d0*(hu**2)*(tp + tdp)/16d0/pi**2

     &-3d0*(hd**2)*(tpd + tdpd)/16d0/pi**2) +dlam4


      xlam5 = 0d0

      xlam6 = 0d0

      xlam7 = 0d0


      xm2(1,1) = 2d0*v**2*(xlam1*cosb**2+2d0*xlam6*

     &cosb*sinb + xlam5*sinb**2) + xma**2*sinb**2


      xm2(2,2) = 2d0*v**2*(xlam5*cosb**2+2d0*xlam7*

     &cosb*sinb + xlam2*sinb**2) + xma**2*cosb**2

      xm2(1,2) = 2d0*v**2*(xlam6*cosb**2+(xlam3+xlam4)*

     &cosb*sinb + xlam7*sinb**2) - xma**2*sinb*cosb


      xm2(2,1) = xm2(1,2)


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      xmssu=(0.5d0*(xmq**2+xmur**2)+xmt**2)**0.5d0


      IF(xmc.GT.xmssu) goto 100

      IF(xmc.LT.xmt) xmc=xmt


      tchar=log(xmssu**2/xmc**2)


      del12=(9d0/64d0/pi**2*g2**4+5d0/192d0/pi**2*g1**4)*tchar

      del3p4=(3d0/64d0/pi**2*g2**4+7d0/192d0/pi**2*g1**4

     &+4d0/32/pi**2*g1**2*g2**2)*tchar


      dem112=2d0*del12*v**2*cosb**2

      dem222=2d0*del12*v**2*sinb**2

      dem122=2d0*del3p4*v**2*sinb*cosb


      xm2(1,1)=xm2(1,1)+dem112

      xm2(2,2)=xm2(2,2)+dem222

      xm2(1,2)=xm2(1,2)+dem122

      xm2(2,1)=xm2(2,1)+dem122


  100 CONTINUE


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...END OF CHARGINOS/NEUTRALINOS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      DO 120 i = 1,2

        DO 110 j = 1,2

          xm2p(i,j) = xm2(i,j) + vh(i,j)

  110   CONTINUE

  120 CONTINUE


      trm2p = xm2p(1,1) + xm2p(2,2)

      detm2p = xm2p(1,1)*xm2p(2,2) - xm2p(1,2)*xm2p(2,1)


      xmh2p = (trm2p - (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0

      hm2p = (trm2p + (trm2p**2 - 4d0* detm2p)**0.5d0)/2d0

      hmp = hm2p**0.5d0

      IF(xmh2p.LT.0d0) goto 130

      xmhp = xmh2p**0.5d0

      s2alp = 2d0*xm2p(1,2)/(trm2p**2-4d0*detm2p)**0.5d0

      c2alp = (xm2p(1,1)-xm2p(2,2))/(trm2p**2-4d0*detm2p)**0.5d0

      IF(c2alp.GT.0d0) alp = asin(s2alp)/2d0

      IF(c2alp.LT.0d0) alp = -pi/2d0-asin(s2alp)/2d0

      sa = sin(alp)

      ca = cos(alp)

      sqbma = (sinb*ca - cosb*sa)**2

  130 xin = 1d0

  140 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYGFXX

C...Auxiliary routine to PYRGHM for SUSY Higgs calculations.


      SUBROUTINE pygfxx(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH,

     &stop1,stop2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      dimension diah(2),vh(2,2),vh1(2,2),vh2(2,2),

     &vh3t(2,2),vh3b(2,2),

     &hmix(2,2),al(2,2),xm2(2,2)


C...Statement function.

      g(x,y) = 2d0 - (x+y)/(x-y)*log(x/y)


      IF(dabs(xmu).LT.0.000001d0) xmu = 0.000001d0

      xmq2 = xmq**2

      xmur2 = xmur**2

      xmdl2 = xmdl**2

      tanba = tanb

      sinba = tanba/(tanba**2+1d0)**0.5d0

      cosba = sinba/tanba


      sinb = tanb/(tanb**2+1d0)**0.5d0

      cosb = sinb/tanb

      pi = 3.14159d0

      g2 = (0.0336d0*4d0*pi)**0.5d0

      g12 = (0.0101d0*4d0*pi)

      g1 = g12**0.5d0

      xmz = 91.18d0

      v = 174.1d0

      mw = (g2**2*v**2/2d0)**0.5d0

      alp3 = 0.12d0/(1d0+23/12d0/pi*0.12d0*log(xmt**2/xmz**2))


      xmb = 3d0

      IF(xmq.GT.xmur) xmst = xmq

      IF(xmur.GT.xmq.OR.xmur.EQ.xmq) xmst = xmur


      xmsut = (xmst**2  + xmt**2)**0.5d0


      IF(xmq.GT.xmdl) xmsb = xmq

      IF(xmdl.GT.xmq.OR.xmdl.EQ.xmq) xmsb = xmdl


      xmsub = (xmsb**2 + xmb**2)**0.5d0


      tt = log(xmsut**2/xmt**2)

      tb = log(xmsub**2/xmt**2)


      rxmt = xmt/(1d0+4d0*alp3/3d0/pi)

      ht = rxmt/(174.1d0*sinb)

      htst = rxmt/174.1d0

      hb = xmb/174.1d0/cosb

      g32 = alp3*4d0*pi

      bt2 = -(8d0*g32 - 9d0*ht**2/2d0 - hb**2/2d0)/(4d0*pi)**2

      bb2 = -(8d0*g32 - 9d0*hb**2/2d0 - ht**2/2d0)/(4d0*pi)**2

      al2 = 3d0/8d0/pi**2*ht**2

      bt2st = -(8d0*g32 - 9d0*htst**2/2d0)/(4d0*pi)**2

      alst = 3d0/8d0/pi**2*htst**2

      al1 = 3d0/8d0/pi**2*hb**2


      al(1,1) = al1

      al(1,2) = (al2+al1)/2d0

      al(2,1) = (al2+al1)/2d0

      al(2,2) = al2


      xmt4 = rxmt**4*(1d0+2d0*bt2*tt- al2*tt)

      xmt2 = sqrt(xmt4)

      xmbot4 = xmb**4*(1d0+2d0*bb2*tb - al1*tb)

      xmbot2 = sqrt(xmbot4)


      IF(xma.GT.xmt) THEN

        vi = 174.1d0*(1d0 + 3d0/32d0/pi**2*htst**2*

     &  log(xmt**2/xma**2))

        h1i = vi* cosba

        h2i = vi*sinba

        h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsut**2))**0.25d0

        h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsut**2))**0.25d0

        h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xma**2/xmsub**2))**0.25d0

        h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xma**2/xmsub**2))**0.25d0

      ELSE

        vi = 174.1d0

        h1i = vi*cosb

        h2i = vi*sinb

        h1t = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsut**2))**0.25d0

        h2t = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsut**2))**0.25d0

        h1b = h1i*(1d0+3d0/8d0/pi**2*hb**2*log(xmt**2/xmsub**2))**0.25d0

        h2b = h2i*(1d0+3d0/8d0/pi**2*ht**2*log(xmt**2/xmsub**2))**0.25d0

      ENDIF


      tanbst = h2t/h1t

      sinbt = tanbst/(1d0+tanbst**2)**0.5d0

      cosbt = sinbt/tanbst


      tanbsb = h2b/h1b

      sinbb = tanbsb/(1d0+tanbsb**2)**0.5d0

      cosbb = sinbb/tanbsb


      stop12 = (xmq2 + xmur2)*0.5d0 + xmt2

     &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)

     &+(((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +

     &xmq2 - xmur2)**2*0.25d0 + xmt2*(at-xmu/tanbst)**2)**0.5d0

      stop22 = (xmq2 + xmur2)*0.5d0 + xmt2

     &+1d0/8d0*(g2**2+g1**2)*(h1t**2-h2t**2)

     &- (((g2**2-5d0*g1**2/3d0)/4d0*(h1t**2-h2t**2) +

     &xmq2 - xmur2)**2*0.25d0

     &+ xmt2*(at-xmu/tanbst)**2)**0.5d0

      IF(stop22.LT.0d0) goto 120

      sbot12 = (xmq2 + xmdl2)*0.5d0

     &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)

     &+ (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +

     &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0

      sbot22 = (xmq2 + xmdl2)*0.5d0

     &- 1d0/8d0*(g2**2+g1**2)*(h1b**2-h2b**2)

     &- (((g1**2/3d0-g2**2)/4d0*(h1b**2-h2b**2) +

     &xmq2 - xmdl2)**2*0.25d0 + xmbot2*(ab-xmu*tanbsb)**2)**0.5d0

      IF(sbot22.LT.0d0) goto 120


      stop1 = stop12**0.5d0

      stop2 = stop22**0.5d0

      sbot1 = sbot12**0.5d0

      sbot2 = sbot22**0.5d0


      vh1(1,1) = 1d0/tanbst

      vh1(2,1) = -1d0

      vh1(1,2) = -1d0

      vh1(2,2) = tanbst

      vh2(1,1) = tanbst

      vh2(1,2) = -1d0

      vh2(2,1) = -1d0

      vh2(2,2) = 1d0/tanbst


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C...D-TERMS

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      stw=0.2320d0


      f1t=(xmq2-xmur2)/(stop12-stop22)*(0.5d0-4d0/3d0*stw)*

     &log(stop1/stop2)

     &+(0.5d0-2d0/3d0*stw)*log(stop1*stop2/(xmq2+xmt2))

     &+ 2d0/3d0*stw*log(stop1*stop2/(xmur2+xmt2))


      f1b=(xmq2-xmdl2)/(sbot12-sbot22)*(-0.5d0+2d0/3d0*stw)*

     &log(sbot1/sbot2)

     &+(-0.5d0+1d0/3d0*stw)*log(sbot1*sbot2/(xmq2+xmbot2))

     &- 1d0/3d0*stw*log(sbot1*sbot2/(xmdl2+xmbot2))


      f2t=xmt2**0.5d0*(at-xmu/tanbst)/(stop12-stop22)*

     &(-0.5d0*log(stop12/stop22)

     &+(4d0/3d0*stw-0.5d0)*(xmq2-xmur2)/(stop12-stop22)*

     &g(stop12,stop22))


      f2b=xmbot2**0.5d0*(ab-xmu*tanbsb)/(sbot12-sbot22)*

     &(0.5d0*log(sbot12/sbot22)

     &+(-2d0/3d0*stw+0.5d0)*(xmq2-xmdl2)/(sbot12-sbot22)*

     &g(sbot12,sbot22))


      vh3b(1,1) = xmbot4/(cosbb**2)*(log(sbot1**2*sbot2**2/

     &(xmq2+xmbot2)/(xmdl2+xmbot2))

     &+ 2d0*(ab*(ab-xmu*tanbsb)/(sbot1**2-sbot2**2))*

     &log(sbot1**2/sbot2**2)) +

     &xmbot4/(cosbb**2)*(ab*(ab-xmu*tanbsb)/

     &(sbot1**2-sbot2**2))**2*g(sbot12,sbot22)


      vh3t(1,1) =

     &xmt4/(sinbt**2)*(xmu*(-at+xmu/tanbst)/(stop1**2

     &-stop2**2))**2*g(stop12,stop22)


      vh3b(1,1)=vh3b(1,1)+

     &xmz**2*(2*xmbot2*f1b-xmbot2**0.5d0*ab*f2b)


      vh3t(1,1) = vh3t(1,1) +

     &xmz**2*(xmt2**0.5d0*xmu/tanbst*f2t)


      vh3t(2,2) = xmt4/(sinbt**2)*(log(stop1**2*stop2**2/

     &(xmq2+xmt2)/(xmur2+xmt2))

     &+ 2d0*(at*(at-xmu/tanbst)/(stop1**2-stop2**2))*

     &log(stop1**2/stop2**2)) +

     &xmt4/(sinbt**2)*(at*(at-xmu/tanbst)/

     &(stop1**2-stop2**2))**2*g(stop12,stop22)


      vh3b(2,2) =

     &xmbot4/(cosbb**2)*(xmu*(-ab+xmu*tanbsb)/(sbot1**2

     &-sbot2**2))**2*g(sbot12,sbot22)


      vh3t(2,2)=vh3t(2,2)+

     &xmz**2*(-2*xmt2*f1t+xmt2**0.5d0*at*f2t)


      vh3b(2,2) = vh3b(2,2) -xmz**2*xmbot2**0.5d0*xmu*tanbsb*f2b


      vh3t(1,2) = -

     &xmt4/(sinbt**2)*xmu*(at-xmu/tanbst)/

     &(stop1**2-stop2**2)*(log(stop1**2/stop2**2) + at*

     &(at - xmu/tanbst)/(stop1**2-stop2**2)*g(stop12,stop22))


      vh3b(1,2) =

     &- xmbot4/(cosbb**2)*xmu*(at-xmu*tanbsb)/

     &(sbot1**2-sbot2**2)*(log(sbot1**2/sbot2**2) + ab*

     &(ab - xmu*tanbsb)/(sbot1**2-sbot2**2)*g(sbot12,sbot22))


      vh3t(1,2)=vh3t(1,2) +

     &xmz**2*(xmt2/tanbst*f1t-xmt2**0.5d0*(at/tanbst+xmu)/2d0*f2t)


      vh3b(1,2)=vh3b(1,2)

     &+xmz**2*(-xmbot2*tanbsb*f1b+xmbot2**0.5d0*(ab*tanbsb+xmu)/2d0*f2b)


      vh3t(2,1) = vh3t(1,2)

      vh3b(2,1) = vh3b(1,2)


      tq = log((xmq2 + xmt2)/xmt2)

      tu = log((xmur2+xmt2)/xmt2)

      tqd = log((xmq2 + xmb**2)/xmb**2)

      td = log((xmdl2+xmb**2)/xmb**2)


      DO 110 i = 1,2

        DO 100 j = 1,2


          vh(i,j) =

     &    6d0/(8d0*pi**2*(h1t**2+h2t**2))

     &    *vh3t(i,j)*0.5d0*(1d0-al(i,j)*tt/2d0) +

     &    6d0/(8d0*pi**2*(h1b**2+h2b**2))

     &    *vh3b(i,j)*0.5d0*(1d0-al(i,j)*tb/2d0)


  100   CONTINUE

  110 CONTINUE


      goto 150

  120 DO 140 i =1,2

        DO 130 j = 1,2

          vh(i,j) = -1d+15

  130   CONTINUE

  140 CONTINUE


  150 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYFINT

C...Auxiliary routine to PYVACU for SUSY Higgs calculations.


      FUNCTION pyfint(A,B,C)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblock.

      common/pyints/xxm(20)

      SAVE/pyints/


C...Local variables.

      EXTERNAL pyfisb


      xxm(1)=a

      xxm(2)=b

      xxm(3)=c

      pyfint  = pygaus(pyfisb,xlo,xhi,1d-3)


      RETURN

      END


C*********************************************************************


C...PYFISB

C...Auxiliary routine to PYFINT for SUSY Higgs calculations.


      FUNCTION pyfisb(X)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblock.

      common/pyints/xxm(20)

      SAVE/pyints/


      pyfisb = log(abs(x*xxm(2)+(1-x)*xxm(3)-x*(1-x)*xxm(1))/

     &(x*(xxm(2)-xxm(3))+xxm(3)))


      RETURN

      END


C*********************************************************************


C...PYSFDC

C...Calculates decays of sfermions.


      SUBROUTINE pysfdc(KFIN,XLAM,IDLAM,IKNT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/


C...Local variables.

      INTEGER kfin,kcin

      DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,xmz,

     &xmz2,axmj,axmi

      DOUBLE PRECISION xmi2,xmi3,xmj2,xma2,xmb2,xmfp

      DOUBLE PRECISION pylamf,xl

      DOUBLE PRECISION tanw,xw,aem,c1,as

      DOUBLE PRECISION ca,cb,al,ar,bl,br,alp,arp,blp,brp

      DOUBLE PRECISION ch1,ch2,ch3,ch4

      DOUBLE PRECISION xmbot,xmtop

      DOUBLE PRECISION xlam(0:200)

      INTEGER idlam(200,3)

      INTEGER lknt,ix,ic,ilr,idu,j,ij,i,iknt,ifl,ifp,ii

      DOUBLE PRECISION sr2

      DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k

      DOUBLE PRECISION cw

      DOUBLE PRECISION beta,alfa,xmu,at,ab,atrit,atrib,atril

      DOUBLE PRECISION cosa,sina,tanb

      DOUBLE PRECISION pyalem,pi,pyalps,ei,pyrnmt

      DOUBLE PRECISION ghrr,ghll,ghlr,cf,xmb,blr

      INTEGER ig,kf1,kf2,ilr2,idp

      INTEGER igg(4),kfnchi(4),kfcchi(2)

      DATA igg/23,25,35,36/

      DATA pi/3.141592654d0/

      DATA sr2/1.4142136d0/

      DATA kfnchi/1000022,1000023,1000025,1000035/

      DATA kfcchi/1000024,1000037/


C...COUNT THE NUMBER OF DECAY MODES

      lknt=0


C...NO NU_R DECAYS

      IF(kfin.EQ.ksusy2+12.OR.kfin.EQ.ksusy2+14.OR.

     &kfin.EQ.ksusy2+16) RETURN


      xmw=pmas(24,1)

      xmw2=xmw**2

      xmz=pmas(23,1)

      xmz2=xmz**2

      xw=paru(102)

      tanw = sqrt(xw/(1d0-xw))

      cw=sqrt(1d0-xw)


C...KCIN

      kcin=pycomp(kfin)

C...ILR is 1 for left and 2 for right.

      ilr=kfin/ksusy1

C...IFL is matching non-SUSY flavour.

      ifl=mod(kfin,ksusy1)

C...IDU is weak isospin, 1 for down and 2 for up.

      idu=2-mod(ifl,2)


      xmi=pmas(kcin,1)

      xmi2=xmi**2

      aem=pyalem(xmi2)

      as =pyalps(xmi2)

      c1=aem/xw

      xmi3=xmi**3

      ei=kchg(ifl,1)/3d0


      xmbot=3d0

      xmtop=pyrnmt(pmas(6,1))

      xmbot=0d0


      tanb=rmss(5)

      beta=atan(tanb)

      alfa=rmss(18)

      cbeta=cos(beta)

      sbeta=tanb*cbeta

      sina=sin(alfa)

      cosa=cos(alfa)

      xmu=-rmss(4)

      atrit=rmss(16)

      atrib=rmss(15)

      atril=rmss(17)


C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION


      IF(imss(11).EQ.1) THEN

        xmp=rmss(28)

        idg=39+ksusy1

        xmgr=pmas(pycomp(idg),1)

        xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi

        IF(ifl.EQ.5) THEN

          xmf=xmbot

        ELSEIF(ifl.EQ.6) THEN

          xmf=xmtop

        ELSE

          xmf=pmas(ifl,1)

        ENDIF

        IF(xmi.GT.xmgr+xmf) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=ifl

          idlam(lknt,3)=0

          xlam(lknt)=xfac*(1d0-xmf**2/xmi2)**4

        ENDIF

      ENDIF


C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO


C...CHARGED DECAYS:

      DO 100 ix=1,2

C...DI -> U CHI1-,CHI2-

        IF(idu.EQ.1) THEN

          xmfp=pmas(ifl+1,1)

          xmf =pmas(ifl,1)

C...UI -> D CHI1+,CHI2+

        ELSE

          xmfp=pmas(ifl-1,1)

          xmf =pmas(ifl,1)

        ENDIF

        xmj=smw(ix)

        axmj=abs(xmj)

        IF(xmi.GE.axmj+xmfp) THEN

          xma2=xmj**2

          xmb2=xmfp**2

          IF(idu.EQ.2) THEN

            IF(ifl.EQ.6) THEN

              xmfp=xmbot

              xmf =xmtop

            ELSEIF(ifl.LT.6) THEN

              xmf=0d0

              xmfp=0d0

            ENDIF

            bl=vmix(ix,1)

            al=-xmfp*umix(ix,2)/sr2/xmw/cbeta

            br=-xmf*vmix(ix,2)/sr2/xmw/sbeta

            ar=0d0

          ELSE

            IF(ifl.EQ.5) THEN

              xmf =xmbot

              xmfp=xmtop

            ELSEIF(ifl.LT.5) THEN

              xmf=0d0

              xmfp=0d0

            ENDIF

            bl=umix(ix,1)

            al=-xmfp*vmix(ix,2)/sr2/xmw/sbeta

            br=-xmf*umix(ix,2)/sr2/xmw/cbeta

            ar=0d0

          ENDIF


          alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar

          blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br

          arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al

          brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl

          al=alp

          bl=blp

          ar=arp

          br=brp


C...F1 -> F` CHI

          IF(ilr.EQ.1) THEN

            ca=al

            cb=bl

C...F2 -> F` CHI

          ELSE

            ca=ar

            cb=br

          ENDIF

          lknt=lknt+1

          xl=pylamf(xmi2,xma2,xmb2)

C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT

          xlam(lknt)=2d0*c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*

     &    (ca**2+cb**2)-4d0*ca*cb*xmj*xmfp)

          idlam(lknt,3)=0

          IF(idu.EQ.1) THEN

            idlam(lknt,1)=-kfcchi(ix)

            idlam(lknt,2)=ifl+1

          ELSE

            idlam(lknt,1)=kfcchi(ix)

            idlam(lknt,2)=ifl-1

          ENDIF

        ENDIF

  100 CONTINUE


C...NEUTRAL DECAYS

      DO 110 ix=1,4

C...DI -> D CHI10

        xmf=pmas(ifl,1)

        xmj=smz(ix)

        axmj=abs(xmj)

        IF(xmi.GE.axmj+xmf) THEN

          xma2=xmj**2

          xmb2=xmf**2

          IF(idu.EQ.1) THEN

            IF(ifl.EQ.5) THEN

              xmf=xmbot

            ELSEIF(ifl.LT.5) THEN

              xmf=0d0

            ENDIF

            bl=-zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei+1)

            al=xmf*zmix(ix,3)/xmw/cbeta

            ar=-2d0*ei*tanw*zmix(ix,1)

            br=al

          ELSE

            IF(ifl.EQ.6) THEN

              xmf=xmtop

            ELSEIF(ifl.LT.5) THEN

              xmf=0d0

            ENDIF

            bl=zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-1)

            al=xmf*zmix(ix,4)/xmw/sbeta

            ar=-2d0*ei*tanw*zmix(ix,1)

            br=al

          ENDIF


          alp=sfmix(ifl,1)*al + sfmix(ifl,2)*ar

          blp=sfmix(ifl,1)*bl + sfmix(ifl,2)*br

          arp=sfmix(ifl,4)*ar + sfmix(ifl,3)*al

          brp=sfmix(ifl,4)*br + sfmix(ifl,3)*bl

          al=alp

          bl=blp

          ar=arp

          br=brp


C...F1 -> F CHI

          IF(ilr.EQ.1) THEN

            ca=al

            cb=bl

C...F2 -> F CHI

          ELSE

            ca=ar

            cb=br

          ENDIF

          lknt=lknt+1

          xl=pylamf(xmi2,xma2,xmb2)

C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT

          xlam(lknt)=c1/8d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*

     &    (ca**2+cb**2)-4d0*ca*cb*xmj*xmf)

          idlam(lknt,1)=kfnchi(ix)

          idlam(lknt,2)=ifl

          idlam(lknt,3)=0

        ENDIF

  110 CONTINUE


C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS

C...IG=23,25,35,36

      DO 120 ii=1,4

        ig=igg(ii)

        IF(ilr.EQ.1) goto 120

        xmb=pmas(ig,1)

        xmsf1=pmas(pycomp(kfin-ksusy1),1)

        IF(xmi.LT.xmsf1+xmb) goto 120

        IF(ig.EQ.23) THEN

          bl=-sign(.5d0,ei)/cw+ei*xw/cw

          br=ei*xw/cw

          blr=0d0

        ELSEIF(ig.EQ.25) THEN

          IF(ifl.EQ.5) THEN

            xmf=xmbot

          ELSEIF(ifl.EQ.6) THEN

            xmf=xmtop

          ELSEIF(ifl.LT.5) THEN

            xmf=0d0

          ELSE

            xmf=pmas(ifl,1)

          ENDIF

          IF(idu.EQ.2) THEN

            ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+

     &      xmf**2/xmw*cosa/sbeta

            ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+

     &      xmf**2/xmw*cosa/sbeta

          ELSE

            ghll=xmz/cw*(0.5d0-ei*xw)*(-sin(alfa+beta))+

     &      xmf**2/xmw*(-sina)/cbeta

            ghrr=xmz/cw*(ei*xw)*(-sin(alfa+beta))+

     &      xmf**2/xmw*(-sina)/cbeta

          ENDIF

          IF(ifl.EQ.5) THEN

            at=atrib

          ELSEIF(ifl.EQ.6) THEN

            at=atrit

          ELSEIF(ifl.EQ.15) THEN

            at=atril

          ELSE

            at=0d0

          ENDIF

          IF(idu.EQ.2) THEN

            ghlr=xmf/2d0/xmw/sbeta*(-xmu*sina+

     &      at*cosa)

          ELSE

            ghlr=xmf/2d0/xmw/cbeta*(xmu*cosa-

     &      at*sina)

          ENDIF

          bl=ghll

          br=ghrr

          blr=-ghlr

        ELSEIF(ig.EQ.35) THEN

          IF(ifl.EQ.5) THEN

            xmf=xmbot

          ELSEIF(ifl.EQ.6) THEN

            xmf=xmtop

          ELSEIF(ifl.LT.5) THEN

            xmf=0d0

          ELSE

            xmf=pmas(ifl,1)

          ENDIF

          IF(idu.EQ.2) THEN

            ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+

     &      xmf**2/xmw*sina/sbeta

            ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+

     &      xmf**2/xmw*sina/sbeta

          ELSE

            ghll=xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)+

     &      xmf**2/xmw*cosa/cbeta

            ghrr=xmz/cw*(ei*xw)*cos(alfa+beta)+

     &      xmf**2/xmw*cosa/cbeta

          ENDIF

          IF(ifl.EQ.5) THEN

            at=atrib

          ELSEIF(ifl.EQ.6) THEN

            at=atrit

          ELSEIF(ifl.EQ.15) THEN

            at=atril

          ELSE

            at=0d0

          ENDIF

          IF(idu.EQ.2) THEN

            ghlr=xmf/2d0/xmw/sbeta*(xmu*cosa+

     &      at*sina)

          ELSE

            ghlr=xmf/2d0/xmw/cbeta*(xmu*sina+

     &      at*cosa)

          ENDIF

          bl=ghll

          br=ghrr

          blr=ghlr

        ELSEIF(ig.EQ.36) THEN

          ghll=0d0

          ghrr=0d0

          IF(ifl.EQ.5) THEN

            xmf=xmbot

          ELSEIF(ifl.EQ.6) THEN

            xmf=xmtop

          ELSEIF(ifl.LT.5) THEN

            xmf=0d0

          ELSE

            xmf=pmas(ifl,1)

          ENDIF

          IF(ifl.EQ.5) THEN

            at=atrib

          ELSEIF(ifl.EQ.6) THEN

            at=atrit

          ELSEIF(ifl.EQ.15) THEN

            at=atril

          ELSE

            at=0d0

          ENDIF

          IF(idu.EQ.2) THEN

            ghlr=xmf/2d0/xmw*(-xmu+at/tanb)

          ELSE

            ghlr=xmf/2d0/xmw/(-xmu+at*tanb)

          ENDIF

          bl=ghll

          br=ghrr

          blr=ghlr

        ENDIF

        al=sfmix(ifl,1)*sfmix(ifl,3)*bl+

     &  sfmix(ifl,2)*sfmix(ifl,4)*br+

     &  (sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,3)*sfmix(ifl,2))*blr

        xl=pylamf(xmi2,xmsf1**2,xmb**2)

        lknt=lknt+1

        IF(ig.EQ.23) THEN

          xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2

        ELSE

          xlam(lknt)=c1/4d0/xmi3*sqrt(xl)*al**2

        ENDIF

        idlam(lknt,3)=0

        idlam(lknt,1)=kfin-ksusy1

        idlam(lknt,2)=ig

  120 CONTINUE


C...SF -> SF' + W

      xmb=pmas(24,1)

      IF(mod(ifl,2).EQ.0) THEN

        kf1=ksusy1+ifl-1

      ELSE

        kf1=ksusy1+ifl+1

      ENDIF

      kf2=kf1+ksusy1

      xmsf1=pmas(pycomp(kf1),1)

      xmsf2=pmas(pycomp(kf2),1)

      IF(xmi.GT.xmb+xmsf1) THEN

        IF(mod(ifl,2).EQ.0) THEN

          IF(ilr.EQ.1) THEN

            al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,1)

          ELSE

            al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,1)

          ENDIF

        ELSE

          IF(ilr.EQ.1) THEN

            al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,1)

          ELSE

            al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,1)

          ENDIF

        ENDIF

        xl=pylamf(xmi2,xmsf1**2,xmb**2)

        lknt=lknt+1

        xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2

        idlam(lknt,3)=0

        idlam(lknt,1)=kf1

        idlam(lknt,2)=sign(24,kchg(ifl,1))

      ENDIF

      IF(xmi.GT.xmb+xmsf2) THEN

        IF(mod(ifl,2).EQ.0) THEN

          IF(ilr.EQ.1) THEN

            al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl-1,3)

          ELSE

            al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl-1,3)

          ENDIF

        ELSE

          IF(ilr.EQ.1) THEN

            al=1d0/sr2*sfmix(ifl,1)*sfmix(ifl+1,3)

          ELSE

            al=1d0/sr2*sfmix(ifl,3)*sfmix(ifl+1,3)

          ENDIF

        ENDIF

        xl=pylamf(xmi2,xmsf2**2,xmb**2)

        lknt=lknt+1

        xlam(lknt)=c1/4d0/xmi3*xl**1.5d0/xmb**2*al**2

        idlam(lknt,3)=0

        idlam(lknt,1)=kf2

        idlam(lknt,2)=sign(24,kchg(ifl,1))

      ENDIF


C...SF -> SF' + HC

      xmb=pmas(37,1)

      IF(mod(ifl,2).EQ.0) THEN

        kf1=ksusy1+ifl-1

      ELSE

        kf1=ksusy1+ifl+1

      ENDIF

      kf2=kf1+ksusy1

      xmsf1=pmas(pycomp(kf1),1)

      xmsf2=pmas(pycomp(kf2),1)

      IF(xmi.GT.xmb+xmsf1) THEN

        xmf=0d0

        xmfp=0d0

        at=0d0

        ab=0d0

        IF(mod(ifl,2).EQ.0) THEN

C...T1-> B1 HC

          IF(ilr.EQ.1) THEN

            ch1=-sfmix(ifl,1)*sfmix(ifl-1,1)

            ch2= sfmix(ifl,2)*sfmix(ifl-1,2)

            ch3=-sfmix(ifl,1)*sfmix(ifl-1,2)

            ch4=-sfmix(ifl,2)*sfmix(ifl-1,1)

C...T2-> B1 HC

          ELSE

            ch1= sfmix(ifl,3)*sfmix(ifl-1,1)

            ch2=-sfmix(ifl,4)*sfmix(ifl-1,2)

            ch3= sfmix(ifl,3)*sfmix(ifl-1,2)

            ch4= sfmix(ifl,4)*sfmix(ifl-1,1)

          ENDIF

          IF(ifl.EQ.6) THEN

            xmf=xmtop

            xmfp=xmbot

            at=atrit

            ab=atrib

          ENDIF

        ELSE

C...B1 -> T1 HC

          IF(ilr.EQ.1) THEN

            ch1=-sfmix(ifl+1,1)*sfmix(ifl,1)

            ch2= sfmix(ifl+1,2)*sfmix(ifl,2)

            ch3=-sfmix(ifl+1,1)*sfmix(ifl,2)

            ch4=-sfmix(ifl+1,2)*sfmix(ifl,1)

C...B2-> T1 HC

          ELSE

            ch1= sfmix(ifl,3)*sfmix(ifl+1,1)

            ch2=-sfmix(ifl,4)*sfmix(ifl+1,2)

            ch3= sfmix(ifl,4)*sfmix(ifl+1,1)

            ch4= sfmix(ifl,3)*sfmix(ifl+1,2)

          ENDIF

          IF(ifl.EQ.5) THEN

            xmf=xmtop

            xmfp=xmbot

            at=atrit

            ab=atrib

          ENDIF

        ENDIF

        xl=pylamf(xmi2,xmsf1**2,xmb**2)

        lknt=lknt+1

        al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+

     &  ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+

     &  ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)

        xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2

        idlam(lknt,3)=0

        idlam(lknt,1)=kf1

        idlam(lknt,2)=sign(37,kchg(ifl,1))

      ENDIF

      IF(xmi.GT.xmb+xmsf2) THEN

        xmf=0d0

        xmfp=0d0

        at=0d0

        ab=0d0

        IF(mod(ifl,2).EQ.0) THEN

C...T1-> B2 HC

          IF(ilr.EQ.1) THEN

            ch1= sfmix(ifl-1,3)*sfmix(ifl,1)

            ch2=-sfmix(ifl-1,4)*sfmix(ifl,2)

            ch3= sfmix(ifl-1,4)*sfmix(ifl,1)

            ch4= sfmix(ifl-1,3)*sfmix(ifl,2)

C...T2-> B2 HC

          ELSE

            ch1= -sfmix(ifl,3)*sfmix(ifl-1,3)

            ch2= sfmix(ifl,4)*sfmix(ifl-1,4)

            ch3= -sfmix(ifl,3)*sfmix(ifl-1,4)

            ch4= -sfmix(ifl,4)*sfmix(ifl-1,3)

          ENDIF

          IF(ifl.EQ.6) THEN

            xmf=xmtop

            xmfp=xmbot

            at=atrit

            ab=atrib

          ENDIF

        ELSE

C...B1 -> T2 HC

          IF(ilr.EQ.1) THEN

            ch1= sfmix(ifl+1,3)*sfmix(ifl,1)

            ch2=-sfmix(ifl+1,4)*sfmix(ifl,2)

            ch3= sfmix(ifl+1,3)*sfmix(ifl,2)

            ch4= sfmix(ifl+1,4)*sfmix(ifl,1)

C...B2-> T2 HC

          ELSE

            ch1= -sfmix(ifl+1,3)*sfmix(ifl,3)

            ch2= sfmix(ifl+1,4)*sfmix(ifl,4)

            ch3= -sfmix(ifl+1,3)*sfmix(ifl,4)

            ch4= -sfmix(ifl+1,4)*sfmix(ifl,3)

          ENDIF

          IF(ifl.EQ.5) THEN

            xmf=xmtop

            xmfp=xmbot

            at=atrit

            ab=atrib

          ENDIF

        ENDIF

        xl=pylamf(xmi2,xmsf1**2,xmb**2)

        lknt=lknt+1

        al=ch1*(xmw2*2d0*cbeta*sbeta-xmfp**2*tanb-xmf**2/tanb)+

     &  ch2*2d0*xmf*xmfp/(2d0*cbeta*sbeta)+

     &  ch3*xmfp*(-xmu+ab*tanb)+ch4*xmf*(-xmu+at/tanb)

        xlam(lknt)=c1/8d0/xmi3*sqrt(xl)/xmw2*al**2

        idlam(lknt,3)=0

        idlam(lknt,1)=kf2

        idlam(lknt,2)=sign(37,kchg(ifl,1))

      ENDIF


C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO


      IF(ifl.LE.6) THEN

        xmfp=0d0

        xmf=0d0

        IF(ifl.EQ.6) xmf=pmas(6,1)

        IF(ifl.EQ.5) xmf=pmas(5,1)

        xmj=pmas(pycomp(ksusy1+21),1)

        axmj=abs(xmj)

        IF(xmi.GE.axmj+xmf) THEN

          al=-sfmix(ifl,2)

          bl=sfmix(ifl,1)

          ar=-sfmix(ifl,4)

          br=sfmix(ifl,3)

C...F1 -> F CHI

          IF(ilr.EQ.1) THEN

            ca=al

            cb=bl

C...F2 -> F CHI

          ELSE

            ca=ar

            cb=br

          ENDIF

          lknt=lknt+1

          xma2=xmj**2

          xmb2=xmf**2

          xl=pylamf(xmi2,xma2,xmb2)

          xlam(lknt)=4d0/3d0*as/2d0/xmi3*sqrt(xl)*((xmi2-xmb2-xma2)*

     &    (ca**2+cb**2)-4d0*ca*cb*xmj*xmf)

          idlam(lknt,1)=ksusy1+21

          idlam(lknt,2)=ifl

          idlam(lknt,3)=0

        ENDIF

      ENDIF


C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0

      IF(kfin.EQ.ksusy1+6.AND.pmas(kcin,1).GT.

     &pmas(pycomp(ksusy1+22),1)+pmas(4,1)) THEN

C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE

C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)

C...M*M = C1**2 * G**2/(16PI**2)

C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)

        lknt=lknt+1

        xl=pylamf(xmi2,0d0,pmas(pycomp(ksusy1+22),1)**2)

        xlam(lknt)=c1**3/64d0/pi**2/xmi3*sqrt(xl)

        IF(xlam(lknt).EQ.0) xlam(lknt)=1d-3

        idlam(lknt,1)=ksusy1+22

        idlam(lknt,2)=4

        idlam(lknt,3)=0

      ENDIF


      iknt=lknt

      xlam(0)=0d0

      DO 130 i=1,iknt

        IF(xlam(i).LT.0d0) xlam(i)=0d0

        xlam(0)=xlam(0)+xlam(i)

  130 CONTINUE

      IF(xlam(0).EQ.0d0) xlam(0)=1d-3


      RETURN

      END


C*********************************************************************


C...PYGLUI

C...Calculates gluino decay modes.


      SUBROUTINE pyglui(KFIN,XLAM,IDLAM,IKNT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/


C...Local variables.

      INTEGER kfin,kcin,kf

      DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,

     &xmz,xmz2,axmj,axmi

      DOUBLE PRECISION xmi2,xmi3,xmj2,xma2,xmb2,xmfp

      DOUBLE PRECISION c1l,c1r,d1l,d1r

      DOUBLE PRECISION c2l,c2r,d2l,d2r

      DOUBLE PRECISION pylamf,xl

      DOUBLE PRECISION tanw,xw,aem,c1,as,s12max,s12min

      DOUBLE PRECISION ca,cb,al,ar,bl,br

      DOUBLE PRECISION alfa,beta

      DOUBLE PRECISION sw,cw,sinb,cosb,qt,t3

      DOUBLE PRECISION xlam(0:200)

      INTEGER idlam(200,3)

      INTEGER lknt,ix,ic,ilr,idu,j,ij,i,iknt,ifl

      DOUBLE PRECISION sr2

      DOUBLE PRECISION gam

      DOUBLE PRECISION pyalem,pi,pyalps,ei

      DOUBLE PRECISION pygaus

      EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2

      DOUBLE PRECISION prec

      INTEGER kfnchi(4),kfcchi(2)

      DATA pi/3.141592654d0/

      DATA sr2/1.4142136d0/

      DATA prec/1d-2/

      DATA kfnchi/1000022,1000023,1000025,1000035/

      DATA kfcchi/1000024,1000037/


C...COUNT THE NUMBER OF DECAY MODES

      lknt=0

      IF(kfin.NE.ksusy1+21) RETURN

      kcin=pycomp(kfin)


      xmw=pmas(24,1)

      xmw2=xmw**2

      xmz=pmas(23,1)

      xmz2=xmz**2

      xw=paru(102)

      tanw = sqrt(xw/(1d0-xw))


      xmi=pmas(kcin,1)

      axmi=abs(xmi)

      xmi2=xmi**2

      aem=pyalem(xmi2)

      as =pyalps(xmi2)

      c1=aem/xw

      xmi3=xmi**3

      beta=atan(rmss(5))


C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON


      IF(imss(11).EQ.1) THEN

        xmp=rmss(28)

        idg=39+ksusy1

        xmgr=pmas(pycomp(idg),1)

        xfac=(xmi2/(xmp*xmgr))**2*xmi/48d0/pi

        IF(axmi.GT.xmgr) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=21

          idlam(lknt,3)=0

          xlam(lknt)=xfac

        ENDIF

      ENDIF


C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK


      DO 110 ifl=1,6

        DO 100 ilr=1,2

          xmj=pmas(pycomp(ilr*ksusy1+ifl),1)

          axmj=abs(xmj)

          xmf=pmas(ifl,1)

          idu=3-(1+mod(ifl,2))

          IF(xmi.GE.axmj+xmf) THEN

            al=sfmix(ifl,1)

            bl=sfmix(ifl,2)

            ar=sfmix(ifl,3)

            br=sfmix(ifl,4)

C...F1 -> F CHI

            IF(ilr.EQ.1) THEN

              ca=al

              cb=bl

C...F2 -> F CHI

            ELSE

              ca=ar

              cb=br

            ENDIF

            lknt=lknt+1

            xma2=xmj**2

            xmb2=xmf**2

            xl=pylamf(xmi2,xma2,xmb2)

            xlam(lknt)=4d0/8d0*as/4d0/xmi3*sqrt(xl)*((xmi2+xmb2-xma2)*

     &      (ca**2+cb**2)+4d0*ca*cb*xmi*xmf)

            idlam(lknt,1)=ilr*ksusy1+ifl

            idlam(lknt,2)=-ifl

            idlam(lknt,3)=0

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=0

          ENDIF

  100   CONTINUE

  110 CONTINUE


C...3-BODY DECAYS TO GAUGINO FERMION-FERMION

C...GLUINO -> NI Q QBAR

      DO 160 ix=1,4

        xmj=smz(ix)

        axmj=abs(xmj)

        IF(xmi.GE.axmj) THEN

          xxm(1)=0d0

          xxm(2)=xmj

          xxm(3)=0d0

          xxm(4)=xmi

          xxm(5)=pmas(pycomp(ksusy1+1),1)

          xxm(6)=pmas(pycomp(ksusy2+1),1)

          xxm(7)=1d6

          xxm(8)=0d0

          xxm(9)=0d0

          xxm(10)=0d0

          s12min=0d0

          s12max=(xmi-axmj)**2

C...D-TYPE QUARKS

          xxm(11)=0d0

          xxm(12)=0d0

          xxm(13)=1d0

          xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)

          xxm(15)=1d0

          xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)

          IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 120

          IF(xmi.GE.axmj+2d0*pmas(1,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1*as/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-2)

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=1

            idlam(lknt,3)=-1

          ENDIF

          IF(xmi.GE.axmj+2d0*pmas(3,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=3

            idlam(lknt,3)=-3

          ENDIF

  120     CONTINUE

          IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 130

          IF(xmi.GE.axmj+2d0*pmas(5,1)) THEN

            CALL pytbbn(ix,80,-1d0/3d0,axmi,gam)

            lknt=lknt+1

            xlam(lknt)=gam

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=5

            idlam(lknt,3)=-5

          ENDIF

C...U-TYPE QUARKS

  130     CONTINUE

          xxm(5)=pmas(pycomp(ksusy1+2),1)

          xxm(6)=pmas(pycomp(ksusy2+2),1)

          xxm(13)=1d0

          xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)

          xxm(15)=1d0

          xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)

          IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 140

          IF(xmi.GE.axmj+2d0*pmas(2,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1*as/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-2)

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=2

            idlam(lknt,3)=-2

          ENDIF

          IF(xmi.GE.axmj+2d0*pmas(4,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=4

            idlam(lknt,3)=-4

          ENDIF

  140     CONTINUE

C...INCLUDE THE DECAY GLUINO -> NJ + T + T~

C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR

          IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) goto 150

          xmf=pmas(6,1)

          IF(xmi.GE.axmj+2d0*xmf) THEN

            CALL pytbbn(ix,80,2d0/3d0,axmi,gam)

            lknt=lknt+1

            xlam(lknt)=gam

            idlam(lknt,1)=kfnchi(ix)

            idlam(lknt,2)=6

            idlam(lknt,3)=-6

          ENDIF

  150     CONTINUE

        ENDIF

  160 CONTINUE


C...GLUINO -> CI Q QBAR'

      DO 190 ix=1,2

        xmj=smw(ix)

        axmj=abs(xmj)

        IF(xmi.GE.axmj) THEN

          s12min=0d0

          s12max=(axmi-axmj)**2

          xxm(1)=0d0

          xxm(2)=xmj

          xxm(3)=0d0

          xxm(4)=xmi

          xxm(5)=0d0

          xxm(6)=0d0

          xxm(9)=1d6

          xxm(10)=0d0

          xxm(7)=umix(ix,1)*sr2

          xxm(8)=vmix(ix,1)*sr2

          xxm(11)=pmas(pycomp(ksusy1+1),1)

          xxm(12)=pmas(pycomp(ksusy1+2),1)

          IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) goto 170

          IF(xmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN

            lknt=lknt+1

            xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*

     &      pygaus(pyxxw5,s12min,s12max,prec)

            idlam(lknt,1)=kfcchi(ix)

            idlam(lknt,2)=1

            idlam(lknt,3)=-2

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

          ENDIF

          IF(xmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfcchi(ix)

            idlam(lknt,2)=3

            idlam(lknt,3)=-4

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

          ENDIF

  170     CONTINUE


          IF(xmi.GE.pmas(pycomp(ksusy1+5),1)+pmas(5,1)) goto 180

          IF(xmi.GE.pmas(pycomp(ksusy1+6),1)+pmas(6,1)) goto 180

          xmf=pmas(6,1)

          xmfp=pmas(5,1)

          IF(xmi.GE.axmj+xmf+xmfp) THEN

            CALL pytbbc(ix,80,axmi,gam)

            lknt=lknt+1

            xlam(lknt)=gam

            idlam(lknt,1)=kfcchi(ix)

            idlam(lknt,2)=5

            idlam(lknt,3)=-6

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

          ENDIF

  180     CONTINUE

        ENDIF

  190 CONTINUE


      iknt=lknt

      xlam(0)=0d0

      DO 200 i=1,iknt

        IF(xlam(i).LT.0d0) xlam(i)=0d0

        xlam(0)=xlam(0)+xlam(i)

  200 CONTINUE

      IF(xlam(0).EQ.0d0) xlam(0)=1d-6


      RETURN

      END


C*********************************************************************


C...PYTBBN

C...Calculates the three-body decay of gluinos into

C...neutralinos and third generation fermions.


      SUBROUTINE pytbbn(I,NN,E,XMGLU,GAM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/


C...Local variables.

      EXTERNAL pysimp,pylamf

      INTEGER lin,nn

      DOUBLE PRECISION cosd,sind,cosd2,sind2,cos2d,sin2d

      DOUBLE PRECISION hl,hr,fl,fr,hl2,hr2,fl2,fr2

      DOUBLE PRECISION xms2(2),xm,xm2,xmg,xmg2,xmr,xmr2

      DOUBLE PRECISION sbar,smin,smax,xmqa,w,grs,g(0:6),summe(0:100)

      DOUBLE PRECISION ff,hh,hfl,hfr,hrfl,hlfr,xmq4,xm24

      DOUBLE PRECISION xln1,xln2,b1,b2

      DOUBLE PRECISION e,xmglu,gam

      DOUBLE PRECISION pysimp,pylamf

      DOUBLE PRECISION hrb(4),hlb(4),flb(4),frb(4)

      SAVE hrb,hlb,flb,frb

      DOUBLE PRECISION alphaw,alphas,gsu2

      DOUBLE PRECISION hlt(4),hrt(4),flt(4),frt(4)

      SAVE hlt,hrt,flt,frt

      DOUBLE PRECISION amc(2),amn(4),an(4,4),zn(3),flu(4),fru(4),

     &fld(4),frd(4)

      SAVE amc,amn,an,zn,flu,fru,fld,frd

      DOUBLE PRECISION ambot,amsb(2),sinc,cosc

      DOUBLE PRECISION amtop,amst(2),sina,cosa

      SAVE amsb,amst

      DOUBLE PRECISION sinw,cosw,tanw,cosw2,sinw2

      DOUBLE PRECISION rot1(4,4)

      LOGICAL ifirst

      SAVE ifirst

      DATA ifirst/.true./


      tanb=rmss(5)

      sinb=tanb/sqrt(1d0+tanb**2)

      cosb=sinb/tanb

      xw=paru(102)

      sinw=sqrt(xw)

      cosw=sqrt(1d0-xw)

      tanw=sinw/cosw

      amw=pmas(24,1)

      cosc=sfmix(5,1)

      sinc=sfmix(5,3)

      cosa=sfmix(6,1)

      sina=sfmix(6,3)

      ambot=0d0

      amtop=pyrnmt(pmas(6,1))

      w2=sqrt(2d0)

      fakt1=ambot/w2/amw/cosb

      fakt2=amtop/w2/amw/sinb

      IF(ifirst) THEN

        DO 110 ii=1,4

          amn(ii)=smz(ii)

          DO 100 j=1,4

            rot1(ii,j)=0d0

            an(ii,j)=0d0

  100     CONTINUE

  110   CONTINUE

        rot1(1,1)=cosw

        rot1(1,2)=-sinw

        rot1(2,1)=-rot1(1,2)

        rot1(2,2)=rot1(1,1)

        rot1(3,3)=cosb

        rot1(3,4)=sinb

        rot1(4,3)=-rot1(3,4)

        rot1(4,4)=rot1(3,3)

        DO 140 ii=1,4

          DO 130 j=1,4

            DO 120 jj=1,4

              an(ii,j)=an(ii,j)+zmix(ii,jj)*rot1(jj,j)

  120       CONTINUE

  130     CONTINUE

  140   CONTINUE

        DO 150 j=1,4

          zn(1)=-fakt2*(-sinb*an(j,3)+cosb*an(j,4))

          zn(2)=-2d0*w2/3d0*sinw*(tanw*an(j,2)-an(j,1))

          zn(3)=-2*w2/3d0*sinw*an(j,1)-w2*(0.5d0-2d0/3d0*

     &    xw)*an(j,2)/cosw

          hrt(j)=zn(1)*cosa-zn(3)*sina

          hlt(j)=zn(1)*cosa+zn(2)*sina

          flt(j)=zn(3)*cosa+zn(1)*sina

          frt(j)=zn(2)*cosa-zn(1)*sina

          flu(j)=zn(3)

          fru(j)=zn(2)

          zn(1)=-fakt1*(cosb*an(j,3)+sinb*an(j,4))

          zn(2)=w2/3d0*sinw*(tanw*an(j,2)-an(j,1))

          zn(3)=w2/3d0*sinw*an(j,1)+w2*(0.5d0-xw/3d0)*an(j,2)/cosw

          hrb(j)=zn(1)*cosc-zn(3)*sinc

          hlb(j)=zn(1)*cosc+zn(2)*sinc

          flb(j)=zn(3)*cosc+zn(1)*sinc

          frb(j)=zn(2)*cosc-zn(1)*sinc

          fld(j)=zn(3)

          frd(j)=zn(2)

  150   CONTINUE

        amst(1)=pmas(pycomp(ksusy1+6),1)

        amst(2)=pmas(pycomp(ksusy2+6),1)

        amsb(1)=pmas(pycomp(ksusy1+5),1)

        amsb(2)=pmas(pycomp(ksusy2+5),1)

        ifirst=.false.

      ENDIF


      IF(nint(3d0*e).EQ.2) THEN

        hl=hlt(i)

        hr=hrt(i)

        fl=flt(i)

        fr=frt(i)

        cosd=sfmix(6,1)

        sind=sfmix(6,3)

        xms2(1)=pmas(pycomp(ksusy1+6),1)**2

        xms2(2)=pmas(pycomp(ksusy2+6),1)**2

        xm=pmas(6,1)

      ELSE

        hl=hlb(i)

        hr=hrb(i)

        fl=flb(i)

        fr=frb(i)

        cosd=sfmix(5,1)

        sind=sfmix(5,3)

        xms2(1)=pmas(pycomp(ksusy1+5),1)**2

        xms2(2)=pmas(pycomp(ksusy2+5),1)**2

        xm=pmas(5,1)

      ENDIF

      cosd2=cosd*cosd

      sind2=sind*sind

      cos2d=cosd2-sind2

      sin2d=sind*cosd*2d0

      hl2=hl*hl

      hr2=hr*hr

      fl2=fl*fl

      fr2=fr*fr

      ff=fl*fr

      hh=hl*hr

      hfl=hl*fl

      hfr=hr*fr

      hrfl=hr*fl

      hlfr=hl*fr

      xm2=xm*xm

      xmg=xmglu

      xmg2=xmg*xmg

      alphaw=pyalem(xmg2)

      alphas=pyalps(xmg2)

      xmr=amn(i)

      xmr2=xmr*xmr

      xmq4=xmg*xm2*xmr

      xm24=(xmg2+xm2)*(xm2+xmr2)

      smin=4d0*xm2

      smax=(xmg-abs(xmr))**2

      xmqa=xmg2+2d0*xm2+xmr2

      DO 170 lin=1,nn-1

        sbar=smin+dble(lin)*(smax-smin)/dble(nn)

        grs=sbar-xmqa

        w=pylamf(xmg2,xmr2,sbar)*(0.25d0-xm2/sbar)

        w=dsqrt(w)

        xln1=log(abs((grs/2d0+xms2(1)-w)/(grs/2d0+xms2(1)+w)))

        xln2=log(abs((grs/2d0+xms2(2)-w)/(grs/2d0+xms2(2)+w)))

        b1=1d0/(grs/2d0+xms2(1)-w)-1d0/(grs/2d0+xms2(1)+w)

        b2=1d0/(grs/2d0+xms2(2)-w)-1d0/(grs/2d0+xms2(2)+w)

        g(0)=-2d0*(hl2+fl2+hr2+fr2+(hfr-hfl)*sin2d

     &  +2d0*(ff*sind2-hh*cosd2))*w

        g(1)=((hl2+fl2)*(xmqa-2d0*xms2(1)-2d0*xm*xmg*sin2d)

     &  +4d0*hfl*xm*xmr)*xln1

     &  +((hl2+fl2)*((xmqa-xms2(1))*xms2(1)-xm24

     &  +2d0*xm*xmg*(xm2+xmr2-xms2(1))*sin2d)

     &  -4d0*hfl*xmr*xm*(xmg2+xm2-xms2(1))

     &  +8d0*hfl*xmq4*sin2d)*b1

        g(2)=((hr2+fr2)*(xmqa-2d0*xms2(2)+2d0*xm*xmg*sin2d)

     &  +4d0*hfr*xmr*xm)*xln2

     &  +((hr2+fr2)*((xmqa-xms2(2))*xms2(2)-xm24

     &  +2d0*xmg*xm*sin2d*(xms2(2)-xm2-xmr2))

     &  +4d0*hfr*xm*xmr*(xms2(2)-xmg2-xm2)

     &  -8d0*hfr*xmq4*sin2d)*b2

        g(3)=(2d0*hfl*sin2d*(xms2(1)*(grs+xms2(1))+xm2*(sbar-xmg2-xmr2)

     &  +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hl2*sind2+fl2*cosd2)*sbar

     &  -2d0*xmg*xm*hfl*(sbar+xmr2-xmg2)

     &  +xmr*xm*(hl2+fl2)*sin2d*(sbar+xmg2-xmr2)

     &  -4d0*xmq4*(hl2-fl2)*cos2d)/(grs+2d0*xms2(1))*xln1

        g(4)=4d0*cos2d*xm*xmg/(xms2(1)-xms2(2))*

     &  (((hlfr+hrfl)*(xm2+xmr2)+2d0*xm*xmr*(hh+ff))*(xln1-xln2)

     &  +(hlfr+hrfl)*(xms2(2)*xln2-xms2(1)*xln1))

        g(5)=(2d0*(hh*cosd2-ff*sind2)

     &  *((xms2(2)*(xms2(2)+grs)+xm2*xm2+xmg2*xmr2)*xln2

     &  +(xms2(1)*(xms2(1)+grs)+xm2*xm2+xmg2*xmr2)*xln1)

     &  +xm*((hh-ff)*sin2d*xmg-(hrfl-hlfr)*xmr)

     &  *((grs+xms2(1)*2d0)*xln1-(grs+xms2(2)*2d0)*xln2)

     &  +((hrfl-hlfr)*xmr*(sin2d*xmg*(sbar-4d0*xm2)

     &  +cos2d*xm*(sbar+xmg2-xmr2))

     &  +2d0*(ff*cosd2-hh*sind2)*xm2*(sbar-xmg2-xmr2))

     &  *(xln1+xln2))/(grs+xms2(1)+xms2(2))

        g(6)=(-2d0*hfr*sin2d*(xms2(2)*(grs+xms2(2))+xm2*(sbar-xmg2-xmr2)

     &  +xmg2*xmr2+xm2*xm2)-2d0*xmr*xmg*(hr2*sind2+fr2*cosd2)*sbar

     &  -2d0*xmg*xm*hfr*(sbar+xmr2-xmg2)

     &  -xmr*xm*(hr2+fr2)*sin2d*(sbar+xmg2-xmr2)

     &  -4d0*xmq4*(hr2-fr2)*cos2d)/(grs+2d0*xms2(2))*xln2

        summe(lin)=0d0

        DO 160 j=0,6

          summe(lin)=summe(lin)+g(j)

  160   CONTINUE

  170 CONTINUE

      summe(0)=0d0

      summe(nn)=0d0

      gam = alphaw * alphas * pysimp(summe,smin,smax,nn)

     &/ (16d0 * paru(1) * paru(102) * xmglu**3)


      RETURN

      END


C*********************************************************************


C...PYTBBC

C...Calculates the three-body decay of gluinos into

C...charginos and third generation fermions.


      SUBROUTINE pytbbc(I,NN,XMGLU,GAM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/


C...Local variables.

      EXTERNAL pysimp,pylamf

      INTEGER i,nn,lin

      DOUBLE PRECISION xmg,xmg2,xmb,xmb2,xmr,xmr2

      DOUBLE PRECISION xmt,xmt2,xmst(4),xmsb(4)

      DOUBLE PRECISION ulr(2),vlr(2),xmq2,xmq4,am,w,sbar,smin,smax

      DOUBLE PRECISION summe(0:100),a(4,8)

      DOUBLE PRECISION cos2a,sin2a,cos2c,sin2c

      DOUBLE PRECISION grs,xmq3,xmgbtr,xmgtbr,ant1,ant2,anb1,anb2

      DOUBLE PRECISION xmglu,gam

      DOUBLE PRECISION pysimp,pylamf

      DOUBLE PRECISION xx1(2),xx2(2),aaa(2),bbb(2),ccc(2),

     &ddd(2),eee(2),fff(2)

      SAVE xx1,xx2,aaa,bbb,ccc,ddd,eee,fff

      DOUBLE PRECISION alphaw,alphas,gsu2

      DOUBLE PRECISION amc(2),amn(4)

      SAVE amc,amn

      DOUBLE PRECISION ambot,amsb(2),sinc,cosc

      DOUBLE PRECISION amtop,amst(2),sina,cosa

      SAVE amsb,amst

      DOUBLE PRECISION sinw,cosw,tanw,cosw2,sinw2

      LOGICAL ifirst

      SAVE ifirst

      DATA ifirst/.true./


      tanb=rmss(5)

      sinb=tanb/sqrt(1d0+tanb**2)

      cosb=sinb/tanb

      xw=paru(102)

      sinw=sqrt(xw)

      cosw=sqrt(1d0-xw)

      amw=pmas(24,1)

      cosc=sfmix(5,1)

      sinc=sfmix(5,3)

      cosa=sfmix(6,1)

      sina=sfmix(6,3)

      ambot=0d0

      amtop=pyrnmt(pmas(6,1))

      w2=sqrt(2d0)

      amw=pmas(24,1)

      fakt1=ambot/w2/amw/cosb

      fakt2=amtop/w2/amw/sinb

      IF(ifirst) THEN

        amc(1)=smw(1)

        amc(2)=smw(2)

        DO 100 jj=1,2

          ccc(jj)=fakt1*umix(jj,2)*sinc-umix(jj,1)*cosc

          eee(jj)=fakt2*vmix(jj,2)*cosc

          ddd(jj)=fakt1*umix(jj,2)*cosc+umix(jj,1)*sinc

          fff(jj)=fakt2*vmix(jj,2)*sinc

          xx1(jj)=fakt2*vmix(jj,2)*sina-vmix(jj,1)*cosa

          aaa(jj)=fakt1*umix(jj,2)*cosa

          xx2(jj)=fakt2*vmix(jj,2)*cosa+vmix(jj,1)*sina

          bbb(jj)=fakt1*umix(jj,2)*sina

  100   CONTINUE

        amst(1)=pmas(pycomp(ksusy1+6),1)

        amst(2)=pmas(pycomp(ksusy2+6),1)

        amsb(1)=pmas(pycomp(ksusy1+5),1)

        amsb(2)=pmas(pycomp(ksusy2+5),1)

        ifirst=.false.

      ENDIF

      amtop=pmas(6,1)


      ulr(1)=xx1(i)*xx1(i)+aaa(i)*aaa(i)

      ulr(2)=xx2(i)*xx2(i)+bbb(i)*bbb(i)

      vlr(1)=ccc(i)*ccc(i)+eee(i)*eee(i)

      vlr(2)=ddd(i)*ddd(i)+fff(i)*fff(i)


      cos2a=cosa**2-sina**2

      sin2a=sina*cosa*2d0

      cos2c=cosc**2-sinc**2

      sin2c=sinc*cosc*2d0


      xmg=xmglu

      xmt=amtop

      xmb=0d0

      xmr=amc(i)

      xmg2=xmg*xmg

      alphaw=pyalem(xmg2)

      alphas=pyalps(xmg2)

      xmt2=xmt*xmt

      xmb2=xmb*xmb

      xmr2=xmr*xmr

      xmq2=xmg2+xmt2+xmb2+xmr2

      xmq4=xmg*xmt*xmb*xmr

      xmq3=xmg2*xmr2+xmt2*xmb2

      xmgbtr=(xmg2+xmb2)*(xmt2+xmr2)

      xmgtbr=(xmg2+xmt2)*(xmb2+xmr2)


      xmst(1)=amst(1)*amst(1)

      xmst(2)=amst(1)*amst(1)

      xmst(3)=amst(2)*amst(2)

      xmst(4)=amst(2)*amst(2)

      xmsb(1)=amsb(1)*amsb(1)

      xmsb(2)=amsb(2)*amsb(2)

      xmsb(3)=amsb(1)*amsb(1)

      xmsb(4)=amsb(2)*amsb(2)


      a(1,1)=-cosa*sinc*ccc(i)*aaa(i)-sina*cosc*eee(i)*xx1(i)

      a(1,2)=xmg*xmb*(cosa*cosc*ccc(i)*aaa(i)+sina*sinc*eee(i)*xx1(i))

      a(1,3)=-xmg*xmr*(cosa*cosc*ccc(i)*xx1(i)+sina*sinc*eee(i)*aaa(i))

      a(1,4)=xmb*xmr*(cosa*sinc*ccc(i)*xx1(i)+sina*cosc*eee(i)*aaa(i))

      a(1,5)=xmg*xmt*(cosa*cosc*eee(i)*xx1(i)+sina*sinc*ccc(i)*aaa(i))

      a(1,6)=-xmt*xmb*(cosa*sinc*eee(i)*xx1(i)+sina*cosc*ccc(i)*aaa(i))

      a(1,7)=xmt*xmr*(cosa*sinc*eee(i)*aaa(i)+sina*cosc*ccc(i)*xx1(i))

      a(1,8)=-xmq4*(cosa*cosc*eee(i)*aaa(i)+sina*sinc*ccc(i)*xx1(i))


      a(2,1)=-cosa*cosc*ddd(i)*aaa(i)-sina*sinc*fff(i)*xx1(i)

      a(2,2)=-xmg*xmb*(cosa*sinc*ddd(i)*aaa(i)+sina*cosc*fff(i)*xx1(i))

      a(2,3)=xmg*xmr*(cosa*sinc*ddd(i)*xx1(i)+sina*cosc*fff(i)*aaa(i))

      a(2,4)=xmb*xmr*(cosa*cosc*ddd(i)*xx1(i)+sina*sinc*fff(i)*aaa(i))

      a(2,5)=xmg*xmt*(cosa*sinc*fff(i)*xx1(i)+sina*cosc*ddd(i)*aaa(i))

      a(2,6)=xmt*xmb*(cosa*cosc*fff(i)*xx1(i)+sina*sinc*ddd(i)*aaa(i))

      a(2,7)=-xmt*xmr*(cosa*cosc*fff(i)*aaa(i)+sina*sinc*ddd(i)*xx1(i))

      a(2,8)=-xmq4*(cosa*sinc*fff(i)*aaa(i)+sina*cosc*ddd(i)*xx1(i))


      a(3,1)=-cosa*cosc*eee(i)*xx2(i)-sina*sinc*ccc(i)*bbb(i)

      a(3,2)=xmg*xmb*(cosa*sinc*eee(i)*xx2(i)+sina*cosc*ccc(i)*bbb(i))

      a(3,3)=xmg*xmr*(cosa*sinc*eee(i)*bbb(i)+sina*cosc*ccc(i)*xx2(i))

      a(3,4)=-xmb*xmr*(cosa*cosc*eee(i)*bbb(i)+sina*sinc*ccc(i)*xx2(i))

      a(3,5)=-xmg*xmt*(cosa*sinc*ccc(i)*bbb(i)+sina*cosc*eee(i)*xx2(i))

      a(3,6)=xmt*xmb*(cosa*cosc*ccc(i)*bbb(i)+sina*sinc*eee(i)*xx2(i))

      a(3,7)=xmt*xmr*(cosa*cosc*ccc(i)*xx2(i)+sina*sinc*eee(i)*bbb(i))

      a(3,8)=-xmq4*(cosa*sinc*ccc(i)*xx2(i)+sina*cosc*eee(i)*bbb(i))


      a(4,1)=-cosa*sinc*fff(i)*xx2(i)-sina*cosc*ddd(i)*bbb(i)

      a(4,2)=-xmg*xmb*(cosa*cosc*fff(i)*xx2(i)+sina*sinc*ddd(i)*bbb(i))

      a(4,3)=-xmg*xmr*(cosa*cosc*fff(i)*bbb(i)+sina*sinc*ddd(i)*xx2(i))

      a(4,4)=-xmb*xmr*(cosa*sinc*fff(i)*bbb(i)+sina*cosc*ddd(i)*xx2(i))

      a(4,5)=-xmg*xmt*(cosa*cosc*ddd(i)*bbb(i)+sina*sinc*fff(i)*xx2(i))

      a(4,6)=-xmt*xmb*(cosa*sinc*ddd(i)*bbb(i)+sina*cosc*fff(i)*xx2(i))

      a(4,7)=-xmt*xmr*(cosa*sinc*ddd(i)*xx2(i)+sina*cosc*fff(i)*bbb(i))

      a(4,8)=-xmq4*(cosa*cosc*ddd(i)*xx2(i)+sina*sinc*fff(i)*bbb(i))


      smax=(xmg-abs(xmr))**2

      smin=(xmb+xmt)**2+0.1d0


      DO 120 lin=0,nn-1

        sbar=smin+dble(lin)*(smax-smin)/dble(nn)

        am=(xmg2-xmr2)*(xmt2-xmb2)/2d0/sbar

        grs=sbar-xmq2

        w=pylamf(sbar,xmb2,xmt2)*pylamf(sbar,xmg2,xmr2)

        w=dsqrt(w)/2d0/sbar

        ant1=log(abs((grs/2d0+am+xmst(1)-w)/(grs/2d0+am+xmst(1)+w)))

        ant2=log(abs((grs/2d0+am+xmst(3)-w)/(grs/2d0+am+xmst(3)+w)))

        anb1=log(abs((grs/2d0-am+xmsb(1)-w)/(grs/2d0-am+xmsb(1)+w)))

        anb2=log(abs((grs/2d0-am+xmsb(2)-w)/(grs/2d0-am+xmsb(2)+w)))

        summe(lin)=-ulr(1)*w+(ulr(1)*(xmq2/2d0-xmst(1)-xmg*xmt*sin2a)

     &  +2d0*xx1(i)*aaa(i)*xmr*xmb)*ant1

     &  +(ulr(1)/2d0*(xmst(1)*(xmq2-xmst(1))-xmgtbr

     &  -2d0*xmg*xmt*sin2a*(xmst(1)-xmb2-xmr2))

     &  +2d0*xx1(i)*aaa(i)*xmr*xmb*(xmst(1)-xmg2-xmt2)

     &  +4d0*sin2a*xx1(i)*aaa(i)*xmq4)

     &  *(1d0/(grs/2d0+am+xmst(1)-w)-1d0/(grs/2d0+am+xmst(1)+w))

        summe(lin)=summe(lin)-ulr(2)*w

     &  +(ulr(2)*(xmq2/2d0-xmst(3)+xmg*xmt*sin2a)

     &  -2d0*xx2(i)*bbb(i)*xmr*xmb)*ant2

     &  +(ulr(2)/2d0*(xmst(3)*(xmq2-xmst(3))-xmgtbr

     &  +2d0*xmg*xmt*sin2a*(xmst(3)-xmb2-xmr2))

     &  -2d0*xx2(i)*bbb(i)*xmr*xmb*(xmst(3)-xmg2-xmt2)

     &  +4d0*sin2a*xx2(i)*bbb(i)*xmq4)

     &  *(1d0/(grs/2d0+am+xmst(3)-w)-1d0/(grs/2d0+am+xmst(3)+w))

        summe(lin)=summe(lin)-vlr(1)*w

     &  +(vlr(1)*(xmq2/2d0-xmsb(1)-xmg*xmb*sin2c)

     &  +2d0*ccc(i)*eee(i)*xmr*xmt)*anb1

     &  +(vlr(1)/2d0*(xmsb(1)*(xmq2-xmsb(1))-xmgbtr

     &  -2d0*xmg*xmb*sin2c*(xmsb(1)-xmt2-xmr2))

     &  +2d0*ccc(i)*eee(i)*xmr*xmt*(xmsb(1)-xmg2-xmb2)

     &  +4d0*sin2c*ccc(i)*eee(i)*xmq4)

     &  *(1d0/(grs/2d0-am+xmsb(1)-w)-1d0/(grs/2d0-am+xmsb(1)+w))

        summe(lin)=summe(lin)-vlr(2)*w

     &  +(vlr(2)*(xmq2/2d0-xmsb(2)+xmg*xmb*sin2c)

     &  -2d0*ddd(i)*fff(i)*xmr*xmt)*anb2

     &  +(vlr(2)/2d0*(xmsb(2)*(xmq2-xmsb(2))-xmgbtr

     &  +2d0*xmg*xmb*sin2c*(xmsb(2)-xmt2-xmr2))

     &  -2d0*ddd(i)*fff(i)*xmr*xmt*(xmsb(2)-xmg2-xmb2)

     &  +4d0*sin2c*ddd(i)*fff(i)*xmq4)

     &  *(1d0/(grs/2d0-am+xmsb(2)-w)-1d0/(grs/2d0-am+xmsb(2)+w))

        summe(lin)=summe(lin)+2d0*xmg*xmt*cos2a/(xmst(3)-xmst(1))

     &  *((aaa(i)*bbb(i)-xx1(i)*xx2(i))

     &  *((xmst(3)-xmb2-xmr2)*ant2-(xmst(1)-xmb2-xmr2)*ant1)

     &  +2d0*(aaa(i)*xx2(i)-xx1(i)*bbb(i))*xmb*xmr*(ant2-ant1))

        summe(lin)=summe(lin)+2d0*xmg*xmb*cos2c/(xmsb(2)-xmsb(1))

     &  *((eee(i)*fff(i)-ccc(i)*ddd(i))

     &  *((xmsb(2)-xmt2-xmr2)*anb2-(xmsb(1)-xmt2-xmr2)*anb1)

     &  +2d0*(eee(i)*ddd(i)-ccc(i)*fff(i))*xmt*xmr*(anb2-anb1))

        DO 110 j=1,4

          summe(lin)=summe(lin)-2d0*a(j,1)*w

     &    +((-a(j,1)*(xmsb(j)*(grs+xmsb(j))+xmq3)

     &    +a(j,2)*(xmsb(j)-xmt2-xmr2)+a(j,3)*(sbar-xmb2-xmt2)

     &    +a(j,4)*(xmsb(j)+sbar-xmb2-xmr2)

     &    -a(j,5)*(xmsb(j)+sbar-xmg2-xmt2)+a(j,6)*(xmg2+xmr2-sbar)

     &    -a(j,7)*(xmsb(j)-xmg2-xmb2)+2d0*a(j,8))

     &    *log(abs((grs/2d0+xmsb(j)-am-w)/(grs/2d0+xmsb(j)-am+w)))

     &    -(a(j,1)*(xmst(j)*(grs+xmst(j))+xmq3)

     &    +a(j,2)*(xmst(j)+sbar-xmg2-xmb2)-a(j,3)*(sbar-xmb2-xmt2)

     &    +a(j,4)*(xmst(j)-xmg2-xmt2)-a(j,5)*(xmst(j)-xmr2-xmb2)

     &    -a(j,6)*(xmg2+xmr2-sbar)

     &    -a(j,7)*(xmst(j)+sbar-xmt2-xmr2)-2d0*a(j,8))

     &    *log(abs((grs/2d0+xmst(j)+am-w)/(grs/2d0+xmst(j)+am+w))))

     &    /(grs+xmsb(j)+xmst(j))

  110   CONTINUE

  120 CONTINUE

      summe(nn)=0d0

      gam= alphaw * alphas * pysimp(summe,smin,smax,nn)

     &/ (16d0 * paru(1) * paru(102) * xmglu**3)


      RETURN

      END


C*********************************************************************


C...PYNJDC

C...Calculates decay widths for the neutralinos (admixtures of

C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)


C...Input:  KCIN = KF code for particle

C...Output: XLAM = widths

C...        IDLAM = KF codes for decay particles

C...        IKNT = number of decay channels defined

C...AUTHOR: STEPHEN MRENNA

C...Last change:

C...10-15-95:  force decay chi^0_2 -> chi^0_1 + gamma

C...when CHIGAMMA .NE. 0

C...10 FEB 96:  Calculate this decay for small tan(beta)


      SUBROUTINE pynjdc(KFIN,XLAM,IDLAM,IKNT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/


C...Local variables.

      INTEGER kfin,kcin

      DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,

     &xmz,xmz2,axmj,axmi

      DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg,xmk

      DOUBLE PRECISION s12min,s12max

      DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2

      DOUBLE PRECISION pylamf,xl,qij,rij

      DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3

      DOUBLE PRECISION pyx2xh,pyx2xg

      DOUBLE PRECISION xlam(0:200)

      INTEGER idlam(200,3)

      INTEGER lknt,ix,ih,j,ij,i,iknt,fid

      INTEGER ith(3),kf1,kf2

      INTEGER ithc

      DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)

      DOUBLE PRECISION sr2

      DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k

      DOUBLE PRECISION gamcon,xmt1,xmt2

      DOUBLE PRECISION pyalem,pi,pyalps

      DOUBLE PRECISION al,bl,ar,br,alp,arp,blp,brp

      DOUBLE PRECISION rat1,rat2

      DOUBLE PRECISION t3t,ca,cb,fcol

      DOUBLE PRECISION alfa,beta,tanb

      DOUBLE PRECISION pygaus,pyxxga

      EXTERNAL pyxxw5,pygaus,pyxxz5

      DOUBLE PRECISION prec

      INTEGER kfnchi(4),kfcchi(2)

      DATA etah/1d0,1d0,-1d0/

      DATA ith/25,35,36/

      DATA ithc/37/

      DATA prec/1d-2/

      DATA pi/3.141592654d0/

      DATA sr2/1.4142136d0/

      DATA kfnchi/1000022,1000023,1000025,1000035/

      DATA kfcchi/1000024,1000037/


C...COUNT THE NUMBER OF DECAY MODES

      lknt=0


      xmw=pmas(24,1)

      xmw2=xmw**2

      xmz=pmas(23,1)

      xmz2=xmz**2

      xw=1d0-xmw2/xmz2

      tanw = sqrt(xw/(1d0-xw))


C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER

      kcin=pycomp(kfin)

      ix=1

      IF(kfin.EQ.kfnchi(2)) ix=2

      IF(kfin.EQ.kfnchi(3)) ix=3

      IF(kfin.EQ.kfnchi(4)) ix=4


      xmi=smz(ix)

      xmi2=xmi**2

      axmi=abs(xmi)

      aem=pyalem(xmi2)

      as =pyalps(xmi2)

      c1=aem/xw

      xmi3=abs(xmi**3)


      tanb=rmss(5)

      beta=atan(tanb)

      alfa=rmss(18)

      cbeta=cos(beta)

      sbeta=tanb*cbeta

      calfa=cos(alfa)

      salfa=sin(alfa)


C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS

      IF(ix.EQ.1.AND.imss(11).EQ.0) THEN

        RETURN

      ENDIF


C...FORCE CHI0_2 -> CHI0_1 + GAMMA

      IF(ix.EQ.2 .AND. imss(10).NE.0 ) THEN

        xmj=smz(1)

        axmj=abs(xmj)

        lknt=lknt+1

        gamcon=aem**3/8d0/pi/xmw2/xw

        xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2

        xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2

        xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)

        idlam(lknt,1)=ksusy1+22

        idlam(lknt,2)=22

        idlam(lknt,3)=0

        WRITE(mstu(11),*) 'FORCED N2 -> N1 + GAMMA ',xlam(lknt)

        goto 290

      ENDIF


C...GRAVITINO DECAY MODES


      IF(imss(11).EQ.1) THEN

        xmp=rmss(28)

        idg=39+ksusy1

        xmgr=pmas(pycomp(idg),1)

        sinw=sqrt(xw)

        cosw=sqrt(1d0-xw)

        xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi

        IF(axmi.GT.xmgr+pmas(22,1)) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=22

          idlam(lknt,3)=0

          xlam(lknt)=xfac*(zmix(ix,1)*cosw+zmix(ix,2)*sinw)**2

        ENDIF

        IF(axmi.GT.xmgr+xmz) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=23

          idlam(lknt,3)=0

          xlam(lknt)=xfac*((zmix(ix,1)*sinw-zmix(ix,2)*cosw)**2 +

     $  .5d0*(zmix(ix,3)*cbeta-zmix(ix,4)*sbeta)**2)*(1d0-xmz2/xmi2)**4

        ENDIF

        IF(axmi.GT.xmgr+pmas(25,1)) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=25

          idlam(lknt,3)=0

          xlam(lknt)=xfac*((zmix(ix,3)*salfa-zmix(ix,4)*calfa)**2)*

     $  .5d0*(1d0-pmas(25,1)**2/xmi2)**4

        ENDIF

        IF(axmi.GT.xmgr+pmas(35,1)) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=35

          idlam(lknt,3)=0

          xlam(lknt)=xfac*((zmix(ix,3)*calfa+zmix(ix,4)*salfa)**2)*

     $  .5d0*(1d0-pmas(35,1)**2/xmi2)**4

        ENDIF

        IF(axmi.GT.xmgr+pmas(36,1)) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=36

          idlam(lknt,3)=0

          xlam(lknt)=xfac*((zmix(ix,3)*sbeta+zmix(ix,4)*cbeta)**2)*

     $  .5d0*(1d0-pmas(36,1)**2/xmi2)**4

        ENDIF

      ENDIF


      DO 180 ij=1,ix-1

        xmj=smz(ij)

        axmj=abs(xmj)

        xmj2=xmj**2


C...CHI0_I -> CHI0_J + GAMMA

        IF(axmi.GE.axmj.AND.sbeta/cbeta.LE.2d0) THEN

          rat1=zmix(ij,1)**2+zmix(ij,2)**2

          rat1=rat1/( 1d-6+zmix(ix,3)**2+zmix(ix,4)**2 )

          rat2=zmix(ix,1)**2+zmix(ix,2)**2

          rat2=rat2/( 1d-6+zmix(ij,3)**2+zmix(ij,4)**2 )

          IF((rat1.GT. 0.90d0 .AND. rat1.LT. 1.10d0) .OR.

     &    (rat2.GT. 0.90d0 .AND. rat2.LT. 1.10d0)) THEN

            lknt=lknt+1

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=22

            idlam(lknt,3)=0

            gamcon=aem**3/8d0/pi/xmw2/xw

            xmt1=(pmas(pycomp(ksusy1+6),1)/pmas(6,1))**2

            xmt2=(pmas(pycomp(ksusy2+6),1)/pmas(6,1))**2

            xlam(lknt)=pyxxga(gamcon,axmi,axmj,xmt1,xmt2)

          ENDIF

        ENDIF


C...CHI0_I -> CHI0_J + Z0

        IF(axmi.GE.axmj+xmz) THEN

          lknt=lknt+1

          gl=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))

          gr=-gl

          xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=23

          idlam(lknt,3)=0

        ELSEIF(axmi.GE.axmj) THEN

          fid=11

          ei=kchg(fid,1)/3d0

          t3=-0.5d0

          xxm(1)=0d0

          xxm(2)=xmj

          xxm(3)=0d0

          xxm(4)=xmi

          xxm(5)=pmas(pycomp(ksusy1+11),1)

          xxm(6)=pmas(pycomp(ksusy2+11),1)

          xxm(7)=xmz

          xxm(8)=pmas(23,2)

          xxm(9)=-0.5d0*(zmix(ix,3)*zmix(ij,3)-zmix(ix,4)*zmix(ij,4))

          xxm(10)=-xxm(9)

          xxm(11)=(t3-ei*xw)/(1d0-xw)

          xxm(12)=-ei*xw/(1d0-xw)

          xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))

          xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))

          xxm(15)=sr2*tanw*(ei*zmix(ix,1))

          xxm(16)=sr2*tanw*(ei*zmix(ij,1))

          s12min=0d0

          s12max=(axmi-axmj)**2


C...CHARGED LEPTONS

          IF( xxm(5).LT.axmi ) THEN

            xxm(5)=1d6

          ENDIF

          IF(xxm(6).LT.axmi ) THEN

            xxm(6)=1d6

          ENDIF

          IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-3)

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=11

            idlam(lknt,3)=-11

            IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfnchi(ij)

              idlam(lknt,2)=13

              idlam(lknt,3)=-13

            ENDIF

          ENDIF

  100     CONTINUE

          IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN

            xxm(5)=pmas(pycomp(ksusy1+15),1)

            xxm(6)=pmas(pycomp(ksusy2+15),1)

          ELSE

            xxm(6)=pmas(pycomp(ksusy1+15),1)

            xxm(5)=pmas(pycomp(ksusy2+15),1)

          ENDIF

          IF( xxm(5).LT.axmi ) THEN

            xxm(5)=1d6

          ENDIF

          IF(xxm(6).LT.axmi ) THEN

            xxm(6)=1d6

          ENDIF


          IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-3)

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=15

            idlam(lknt,3)=-15

          ENDIF


C...NEUTRINOS

  110     CONTINUE

          fid=12

          ei=kchg(fid,1)/3d0

          t3=0.5d0

          xxm(5)=pmas(pycomp(ksusy1+12),1)

          xxm(6)=1d6

          xxm(11)=(t3-ei*xw)/(1d0-xw)

          xxm(12)=-ei*xw/(1d0-xw)

          xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))

          xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))

          xxm(15)=sr2*tanw*(ei*zmix(ix,1))

          xxm(16)=sr2*tanw*(ei*zmix(ij,1))


          IF( xxm(5).LT.axmi ) THEN

            xxm(5)=1d6

          ENDIF


          lknt=lknt+1

          xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz5,s12min,s12max,1d-3)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=12

          idlam(lknt,3)=-12

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=14

          idlam(lknt,3)=-14

  120     CONTINUE

          xxm(5)=pmas(pycomp(ksusy1+16),1)

          IF( xxm(5).LT.axmi ) THEN

            xxm(5)=1d6

          ENDIF

          lknt=lknt+1

          xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz5,s12min,s12max,1d-3)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=16

          idlam(lknt,3)=-16


C...D-TYPE QUARKS

  130     CONTINUE

          xxm(5)=pmas(pycomp(ksusy1+1),1)

          xxm(6)=pmas(pycomp(ksusy2+1),1)

          fid=1

          ei=kchg(fid,1)/3d0

          t3=-0.5d0


          xxm(11)=(t3-ei*xw)/(1d0-xw)

          xxm(12)=-ei*xw/(1d0-xw)

          xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))

          xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))

          xxm(15)=sr2*tanw*(ei*zmix(ix,1))

          xxm(16)=sr2*tanw*(ei*zmix(ij,1))


          IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 140

          IF( xxm(5).LT.axmi ) THEN

            xxm(5)=1d6

          ELSEIF( xxm(6).LT.axmi ) THEN

            xxm(6)=1d6

          ENDIF

          IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-3)*3d0

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=1

            idlam(lknt,3)=-1

            IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfnchi(ij)

              idlam(lknt,2)=3

              idlam(lknt,3)=-3

            ENDIF

          ENDIF

  140     CONTINUE

          IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN

            xxm(5)=pmas(pycomp(ksusy1+5),1)

            xxm(6)=pmas(pycomp(ksusy2+5),1)

          ELSE

            xxm(6)=pmas(pycomp(ksusy1+5),1)

            xxm(5)=pmas(pycomp(ksusy2+5),1)

          ENDIF

          IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 150

          IF(xxm(5).LT.axmi) THEN

            xxm(5)=1d6

          ELSEIF(xxm(6).LT.axmi) THEN

            xxm(6)=1d6

          ENDIF

          IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-3)*3d0

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=5

            idlam(lknt,3)=-5

          ENDIF


C...U-TYPE QUARKS

  150     CONTINUE

          xxm(5)=pmas(pycomp(ksusy1+2),1)

          xxm(6)=pmas(pycomp(ksusy2+2),1)

          fid=2

          ei=kchg(fid,1)/3d0

          t3=0.5d0


          xxm(11)=(t3-ei*xw)/(1d0-xw)

          xxm(12)=-ei*xw/(1d0-xw)

          xxm(13)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))

          xxm(14)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))

          xxm(15)=sr2*tanw*(ei*zmix(ix,1))

          xxm(16)=sr2*tanw*(ei*zmix(ij,1))


          IF( xxm(5).LT.axmi .AND. xxm(6).LT.axmi ) goto 160

          IF(xxm(5).LT.axmi) THEN

            xxm(5)=1d6

          ELSEIF(xxm(6).LT.axmi) THEN

            xxm(6)=1d6

          ENDIF

          IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxz5,s12min,s12max,1d-3)*3d0

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=2

            idlam(lknt,3)=-2

            IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfnchi(ij)

              idlam(lknt,2)=4

              idlam(lknt,3)=-4

            ENDIF

          ENDIF

  160     CONTINUE

        ENDIF


C...CHI0_I -> CHI0_J + H0_K

        eh(1)=sin(alfa)

        eh(2)=cos(alfa)

        eh(3)=-sin(beta)

        dh(1)=cos(alfa)

        dh(2)=-sin(alfa)

        dh(3)=cos(beta)


        qij=zmix(ix,3)*zmix(ij,2)+zmix(ij,3)*zmix(ix,2)-

     &  tanw*(zmix(ix,3)*zmix(ij,1)+zmix(ij,3)*zmix(ix,1))

        rij=zmix(ix,4)*zmix(ij,2)+zmix(ij,4)*zmix(ix,2)-

     &  tanw*(zmix(ix,4)*zmix(ij,1)+zmix(ij,4)*zmix(ix,1))


        DO 170 ih=1,3

          xmh=pmas(ith(ih),1)

          xmh2=xmh**2

          IF(axmi.GE.axmj+xmh) THEN

            lknt=lknt+1

            xl=pylamf(xmi2,xmj2,xmh2)

            f21k=0.5d0*(qij*eh(ih)+rij*dh(ih))

            f12k=f21k

C...SIGN OF MASSES I,J

            xmk=xmj

            IF(ih.EQ.3) xmk=-xmk

            xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=ith(ih)

            idlam(lknt,3)=0

          ENDIF

  170   CONTINUE

  180 CONTINUE


C...CHI0_I -> CHI+_J + W-

      DO 220 ij=1,2

        xmj=smw(ij)

        axmj=abs(xmj)

        xmj2=xmj**2

        IF(axmi.GE.axmj+xmw) THEN

          lknt=lknt+1

          gl=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2

          gr=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2

          xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)

          idlam(lknt,1)=kfcchi(ij)

          idlam(lknt,2)=-24

          idlam(lknt,3)=0

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=-kfcchi(ij)

          idlam(lknt,2)=24

          idlam(lknt,3)=0

        ELSEIF(axmi.GE.axmj) THEN

          s12min=0d0

          s12max=(axmi-axmj)**2

          xxm(5)=zmix(ix,2)*vmix(ij,1)-zmix(ix,4)*vmix(ij,2)/sr2

          xxm(6)=zmix(ix,2)*umix(ij,1)+zmix(ix,3)*umix(ij,2)/sr2


C...LEPTONS

          fid=11

          ei=kchg(fid,1)/3d0

          t3=-0.5d0

          xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)

          fid=12

          ei=kchg(fid,1)/3d0

          t3=0.5d0

          xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)


          xxm(1)=0d0

          xxm(2)=xmj

          xxm(3)=0d0

          xxm(4)=xmi

          xxm(9)=pmas(24,1)

          xxm(10)=pmas(24,2)

          xxm(11)=pmas(pycomp(ksusy1+11),1)

          xxm(12)=pmas(pycomp(ksusy1+12),1)

          IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 190

          IF(xxm(11).LT.axmi) THEN

            xxm(11)=1d6

          ELSEIF(xxm(12).LT.axmi) THEN

            xxm(12)=1d6

          ENDIF

          IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxw5,s12min,s12max,prec)

            idlam(lknt,1)=kfcchi(ij)

            idlam(lknt,2)=11

            idlam(lknt,3)=-12

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

            IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfcchi(ij)

              idlam(lknt,2)=13

              idlam(lknt,3)=-14

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=-idlam(lknt-1,1)

              idlam(lknt,2)=-idlam(lknt-1,2)

              idlam(lknt,3)=-idlam(lknt-1,3)

            ENDIF

          ENDIF

  190     CONTINUE

          IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN

            xxm(11)=pmas(pycomp(ksusy1+15),1)

            xxm(12)=pmas(pycomp(ksusy1+16),1)

          ELSE

            xxm(11)=pmas(pycomp(ksusy2+15),1)

            xxm(12)=pmas(pycomp(ksusy1+16),1)

          ENDIF


          IF(xxm(11).LT.axmi) THEN

            xxm(11)=1d6

          ENDIF

          IF(xxm(12).LT.axmi) THEN

            xxm(12)=1d6

          ENDIF

          IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN

            lknt=lknt+1

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxw5,s12min,s12max,prec)

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfcchi(ij)

            idlam(lknt,2)=15

            idlam(lknt,3)=-16

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

          ENDIF


C...NOW, DO THE QUARKS

  200     CONTINUE

          fid=1

          ei=kchg(fid,1)/3d0

          t3=-0.5d0

          xxm(7)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*umix(ij,1)

          fid=2

          ei=kchg(fid,1)/3d0

          t3=0.5d0

          xxm(8)=-sr2*(t3*zmix(ix,2)-tanw*(t3-ei)*zmix(ix,1))*vmix(ij,1)


          xxm(11)=pmas(pycomp(ksusy1+1),1)

          xxm(12)=pmas(pycomp(ksusy1+2),1)

          IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 210

          IF(xxm(11).LT.axmi) THEN

            xxm(11)=1d6

          ELSEIF(xxm(12).LT.axmi) THEN

            xxm(12)=1d6

          ENDIF

          IF(axmi.GE.axmj+pmas(2,1)+pmas(1,1)) THEN

            lknt=lknt+1

            xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxw5,s12min,s12max,prec)

            idlam(lknt,1)=kfcchi(ij)

            idlam(lknt,2)=1

            idlam(lknt,3)=-2

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=-idlam(lknt-1,1)

            idlam(lknt,2)=-idlam(lknt-1,2)

            idlam(lknt,3)=-idlam(lknt-1,3)

            IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfcchi(ij)

              idlam(lknt,2)=3

              idlam(lknt,3)=-4

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=-idlam(lknt-1,1)

              idlam(lknt,2)=-idlam(lknt-1,2)

              idlam(lknt,3)=-idlam(lknt-1,3)

            ENDIF

          ENDIF

  210     CONTINUE

        ENDIF

  220 CONTINUE

  230 CONTINUE


C...CHI0_I -> CHI+_I + H-

      DO 240 ij=1,2

        xmj=smw(ij)

        axmj=abs(xmj)

        xmj2=xmj**2

        xmhp=pmas(ithc,1)

        xmhp2=xmhp**2

        IF(axmi.GE.axmj+xmhp) THEN

          lknt=lknt+1

          gl=cbeta*(zmix(ix,4)*vmix(ij,1)+(zmix(ix,2)+

     &    zmix(ix,1)*tanw)*vmix(ij,2)/sr2)

          gr=sbeta*(zmix(ix,3)*umix(ij,1)-(zmix(ix,2)+

     &    zmix(ix,1)*tanw)*umix(ij,2)/sr2)

          xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)

          idlam(lknt,1)=kfcchi(ij)

          idlam(lknt,2)=-ithc

          idlam(lknt,3)=0

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=-idlam(lknt-1,1)

          idlam(lknt,2)=-idlam(lknt-1,2)

          idlam(lknt,3)=-idlam(lknt-1,3)

        ELSE


        ENDIF

  240 CONTINUE


C...2-BODY DECAYS TO FERMION SFERMION

      DO 250 j=1,16

        IF(j.GE.7.AND.j.LE.10) goto 250

        kf1=ksusy1+j

        kf2=ksusy2+j

        xmsf1=pmas(pycomp(kf1),1)

        xmsf2=pmas(pycomp(kf2),1)

        xmf=pmas(j,1)

        IF(j.LE.6) THEN

          fcol=3d0

        ELSE

          fcol=1d0

        ENDIF


        ei=kchg(j,1)/3d0

        t3t=sign(1d0,ei)

        IF(j.EQ.12.OR.j.EQ.14.OR.j.EQ.16) t3t=1d0

        IF(mod(j,2).EQ.0) THEN

          bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)

          al=xmf*zmix(ix,4)/xmw/sbeta

          ar=-2d0*ei*tanw*zmix(ix,1)

          br=al

        ELSE

          bl=t3t*zmix(ix,2)+tanw*zmix(ix,1)*(2d0*ei-t3t)

          al=xmf*zmix(ix,3)/xmw/cbeta

          ar=-2d0*ei*tanw*zmix(ix,1)

          br=al

        ENDIF


C...D~ D_L

        IF(axmi.GE.xmf+xmsf1) THEN

          lknt=lknt+1

          xma2=xmsf1**2

          xmb2=xmf**2

          xl=pylamf(xmi2,xma2,xmb2)

          ca=al*sfmix(j,1)+ar*sfmix(j,2)

          cb=bl*sfmix(j,1)+br*sfmix(j,2)

          xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*

     &    (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)

          idlam(lknt,1)=kf1

          idlam(lknt,2)=-j

          idlam(lknt,3)=0

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=-idlam(lknt-1,1)

          idlam(lknt,2)=-idlam(lknt-1,2)

          idlam(lknt,3)=0

        ENDIF


C...D~ D_R

        IF(axmi.GE.xmf+xmsf2) THEN

          lknt=lknt+1

          xma2=xmsf2**2

          xmb2=xmf**2

          ca=al*sfmix(j,3)+ar*sfmix(j,4)

          cb=bl*sfmix(j,3)+br*sfmix(j,4)

          xl=pylamf(xmi2,xma2,xmb2)

          xlam(lknt)=0.5d0*fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*

     &    (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)

          idlam(lknt,1)=kf2

          idlam(lknt,2)=-j

          idlam(lknt,3)=0

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=-idlam(lknt-1,1)

          idlam(lknt,2)=-idlam(lknt-1,2)

          idlam(lknt,3)=0

        ENDIF

  250 CONTINUE


C...3-BODY DECAY TO Q Q~ GLUINO

      xmj=pmas(pycomp(ksusy1+21),1)

      IF(axmi.GE.xmj) THEN

        axmj=abs(xmj)

        xxm(1)=0d0

        xxm(2)=xmj

        xxm(3)=0d0

        xxm(4)=xmi

        xxm(5)=pmas(pycomp(ksusy1+1),1)

        xxm(6)=pmas(pycomp(ksusy2+1),1)

        xxm(7)=1d6

        xxm(8)=0d0

        xxm(9)=0d0

        xxm(10)=0d0

        s12min=0d0

        s12max=(axmi-axmj)**2

C...ALL QUARKS BUT T

        xxm(11)=0d0

        xxm(12)=0d0

        xxm(13)=1d0

        xxm(14)=-sr2*(-0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)

        xxm(15)=1d0

        xxm(16)=sr2*(-tanw*zmix(ix,1)/3d0)

        IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 260

        IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN

          lknt=lknt+1

          xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*

     &    pygaus(pyxxz5,s12min,s12max,1d-3)

          idlam(lknt,1)=ksusy1+21

          idlam(lknt,2)=1

          idlam(lknt,3)=-1

          IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=ksusy1+21

            idlam(lknt,2)=3

            idlam(lknt,3)=-3

          ENDIF

        ENDIF

  260   CONTINUE

        IF(abs(sfmix(5,1)).GT.abs(sfmix(5,2))) THEN

          xxm(5)=pmas(pycomp(ksusy1+5),1)

          xxm(6)=pmas(pycomp(ksusy2+5),1)

        ELSE

          xxm(6)=pmas(pycomp(ksusy1+5),1)

          xxm(5)=pmas(pycomp(ksusy2+5),1)

        ENDIF

        IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 270

        IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN

          lknt=lknt+1

          xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*

     &    pygaus(pyxxz5,s12min,s12max,1d-3)

          idlam(lknt,1)=ksusy1+21

          idlam(lknt,2)=5

          idlam(lknt,3)=-5

        ENDIF

C...U-TYPE QUARKS

  270   CONTINUE

        xxm(5)=pmas(pycomp(ksusy1+2),1)

        xxm(6)=pmas(pycomp(ksusy2+2),1)

        xxm(13)=1d0

        xxm(14)=-sr2*(0.5d0*zmix(ix,2)+tanw*zmix(ix,1)/6d0)

        xxm(15)=1d0

        xxm(16)=sr2*(2d0*tanw*zmix(ix,1)/3d0)

        IF( xxm(5).LT.axmi .OR. xxm(6).LT.axmi ) goto 280

        IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN

          lknt=lknt+1

          xlam(lknt)=0.5d0*c1*as/xmi3/(16d0*pi)*

     &    pygaus(pyxxz5,s12min,s12max,1d-3)

          idlam(lknt,1)=ksusy1+21

          idlam(lknt,2)=2

          idlam(lknt,3)=-2

          IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=ksusy1+21

            idlam(lknt,2)=4

            idlam(lknt,3)=-4

          ENDIF

        ENDIF

  280   CONTINUE

      ENDIF


  290 iknt=lknt

      xlam(0)=0d0

      DO 300 i=1,iknt

        IF(xlam(i).LT.0d0) xlam(i)=0d0

        xlam(0)=xlam(0)+xlam(i)

  300 CONTINUE

      IF(xlam(0).EQ.0d0) xlam(0)=1d-6


      RETURN

      END


C*********************************************************************


C...PYCJDC

C...Calculate decay widths for the charginos (admixtures of

C...charged Wino and charged Higgsino.


C...Input:  KCIN = KF code for particle

C...Output: XLAM = widths

C...        IDLAM = KF codes for decay particles

C...        IKNT = number of decay channels defined

C...AUTHOR: STEPHEN MRENNA

C...Last change:

C...10-16-95:  force decay chi^+_1 -> chi^0_1 e+ nu_e

C...when CHIENU .NE. 0


      SUBROUTINE pycjdc(KFIN,XLAM,IDLAM,IKNT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pydat2/,/pymssm/,/pyssmt/,/pyints/


C...Local variables.

      INTEGER kfin,kcin

      DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,

     &xmz,xmz2,axmj,axmi

      DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg

      DOUBLE PRECISION s12min,s12max

      DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2,xmk

      DOUBLE PRECISION pylamf,xl

      DOUBLE PRECISION tanw,xw,aem,c1,as,ei,t3,beta,alfa

      DOUBLE PRECISION pyx2xh,pyx2xg

      DOUBLE PRECISION xlam(0:200)

      INTEGER idlam(200,3)

      INTEGER lknt,ix,ih,j,ij,i,iknt,fid

      INTEGER ith(3)

      INTEGER ithc

      DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)

      DOUBLE PRECISION sr2

      DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k,tanb


      DOUBLE PRECISION pyalem,pi,pyalps

      DOUBLE PRECISION al,bl,ar,br,alp,blp,arp,brp

      DOUBLE PRECISION ca,cb,fcol

      INTEGER kf1,kf2,isf

      INTEGER kfnchi(4),kfcchi(2)


      DOUBLE PRECISION temp

      DOUBLE PRECISION pygaus

      EXTERNAL pygaus,pyxxz5,pyxxw5,pyxxz2

      DOUBLE PRECISION prec

      DATA ith/25,35,36/

      DATA ithc/37/

      DATA etah/1d0,1d0,-1d0/

      DATA sr2/1.4142136d0/

      DATA pi/3.141592654d0/

      DATA prec/1d-2/

      DATA kfnchi/1000022,1000023,1000025,1000035/

      DATA kfcchi/1000024,1000037/


C...COUNT THE NUMBER OF DECAY MODES

      lknt=0

      xmw=pmas(24,1)

      xmw2=xmw**2

      xmz=pmas(23,1)

      xmz2=xmz**2

      xw=1d0-xmw2/xmz2

      tanw = sqrt(xw/(1d0-xw))


C...1 OR 2 DEPENDING ON CHARGINO TYPE

      ix=1

      IF(kfin.EQ.kfcchi(2)) ix=2

      kcin=pycomp(kfin)


      xmi=smw(ix)

      xmi2=xmi**2

      axmi=abs(xmi)

      aem=pyalem(xmi2)

      as =pyalps(xmi2)

      c1=aem/xw

      xmi3=abs(xmi**3)

      tanb=rmss(5)

      beta=atan(tanb)

      cbeta=cos(beta)

      sbeta=tanb*cbeta

      alfa=rmss(18)


C...GRAVITINO DECAY MODES


      IF(imss(11).EQ.1) THEN

        xmp=rmss(28)

        idg=39+ksusy1

        xmgr=pmas(pycomp(idg),1)

        sinw=sqrt(xw)

        cosw=sqrt(1d0-xw)

        xfac=(xmi2/(xmp*xmgr))**2*axmi/48d0/pi

        IF(axmi.GT.xmgr+xmw) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=24

          idlam(lknt,3)=0

          xlam(lknt)=xfac*(.5d0*(vmix(ix,1)**2+umix(ix,1)**2)+

     &  .5d0*((vmix(ix,2)*sbeta)**2+(umix(ix,2)*cbeta)**2))*

     &  (1d0-xmw2/xmi2)**4

        ENDIF

        IF(axmi.GT.xmgr+pmas(37,1)) THEN

          lknt=lknt+1

          idlam(lknt,1)=idg

          idlam(lknt,2)=37

          idlam(lknt,3)=0

          xlam(lknt)=xfac*(.5d0*((vmix(ix,2)*cbeta)**2+

     &   (umix(ix,2)*sbeta)**2))

     &   *(1d0-pmas(37,1)**2/xmi2)**4

       ENDIF

      ENDIF


C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS

      IF(ix.EQ.1) goto 150

      xmj=smw(1)

      axmj=abs(xmj)

      xmj2=xmj**2


C...CHI_2+ -> CHI_1+ + Z0

      IF(axmi.GE.axmj+xmz) THEN

        lknt=lknt+1

        gl=vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2)

        gr=umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2)

        xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmz,gl,gr)

        idlam(lknt,1)=kfcchi(1)

        idlam(lknt,2)=23

        idlam(lknt,3)=0


C...CHARGED LEPTONS

      ELSEIF(axmi.GE.axmj) THEN

        xxm(5)=-(vmix(2,1)*vmix(1,1)+0.5d0*vmix(2,2)*vmix(1,2))

        xxm(6)=-(umix(2,1)*umix(1,1)+0.5d0*umix(2,2)*umix(1,2))

        xxm(9)=xmz

        xxm(10)=pmas(23,2)

        xxm(1)=0d0

        xxm(2)=xmj

        xxm(3)=0d0

        xxm(4)=xmi

        s12min=0d0

        s12max=(axmj-axmi)**2

        xxm(7)= (-0.5d0+xw)/(1d0-xw)

        xxm(8)= xw/(1d0-xw)

        xxm(11)=pmas(pycomp(ksusy1+12),1)

        xxm(12)=vmix(2,1)*vmix(1,1)

        IF( xxm(11).LT.axmi ) THEN

          xxm(11)=1d6

        ENDIF

        IF(axmi.GE.axmj+2d0*pmas(11,1)) THEN

          lknt=lknt+1

          xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz2,s12min,s12max,prec)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=11

          idlam(lknt,3)=-11

          IF(axmi.GE.axmj+2d0*pmas(13,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfcchi(1)

            idlam(lknt,2)=13

            idlam(lknt,3)=-13

            IF(axmi.GE.axmj+2d0*pmas(15,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfcchi(1)

              idlam(lknt,2)=15

              idlam(lknt,3)=-15

            ENDIF

          ENDIF

        ENDIF


C...NEUTRINOS

  100   CONTINUE

        xxm(7)= (0.5d0)/(1d0-xw)

        xxm(8)= 0d0

        xxm(11)=pmas(pycomp(ksusy1+11),1)

        xxm(12)=umix(2,1)*umix(1,1)

        IF( xxm(11).LT.axmi ) THEN

          xxm(11)=1d6

        ENDIF

        IF(axmi.GE.axmj+2d0*pmas(12,1)) THEN

          lknt=lknt+1

          xlam(lknt)=c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz2,s12min,s12max,prec)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=12

          idlam(lknt,3)=-12

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=14

          idlam(lknt,3)=-14

          lknt=lknt+1

          xlam(lknt)=xlam(lknt-1)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=16

          idlam(lknt,3)=-16

        ENDIF


C...D-TYPE QUARKS

  110   CONTINUE

        xxm(7)= (-0.5d0+xw/3d0)/(1d0-xw)

        xxm(8)= xw/3d0/(1d0-xw)

        xxm(11)=pmas(pycomp(ksusy1+2),1)

        xxm(12)=vmix(2,1)*vmix(1,1)

        IF( xxm(11).LT.axmi ) goto 120

        IF(axmi.GE.axmj+2d0*pmas(1,1)) THEN

          lknt=lknt+1

          xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz2,s12min,s12max,prec)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=1

          idlam(lknt,3)=-1

          IF(axmi.GE.axmj+2d0*pmas(3,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfcchi(1)

            idlam(lknt,2)=3

            idlam(lknt,3)=-3

            IF(axmi.GE.axmj+2d0*pmas(5,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfcchi(1)

              idlam(lknt,2)=5

              idlam(lknt,3)=-5

            ENDIF

          ENDIF

        ENDIF


C...U-TYPE QUARKS

  120   CONTINUE

        xxm(7)= (0.5d0-2d0*xw/3d0)/(1d0-xw)

        xxm(8)= -2d0*xw/3d0/(1d0-xw)

        xxm(11)=pmas(pycomp(ksusy1+1),1)

        xxm(12)=umix(2,1)*umix(1,1)

        IF( xxm(11).LT.axmi ) goto 130

        IF(axmi.GE.axmj+2d0*pmas(2,1)) THEN

          lknt=lknt+1

          xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*

     &    pygaus(pyxxz2,s12min,s12max,prec)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=2

          idlam(lknt,3)=-2

          IF(axmi.GE.axmj+2d0*pmas(4,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=kfcchi(1)

            idlam(lknt,2)=4

            idlam(lknt,3)=-4

          ENDIF

        ENDIF

  130   CONTINUE

      ENDIF


C...CHI_2+ -> CHI_1+ + H0_K

      eh(2)=cos(alfa)

      eh(1)=sin(alfa)

      eh(3)=-sbeta

      dh(2)=-sin(alfa)

      dh(1)=cos(alfa)

      dh(3)=cos(beta)

      DO 140 ih=1,3

        xmh=pmas(ith(ih),1)

        xmh2=xmh**2

C...NO 3-BODY OPTION

        IF(axmi.GE.axmj+xmh) THEN

          lknt=lknt+1

          xl=pylamf(xmi2,xmj2,xmh2)

          f21k=(vmix(2,1)*umix(1,2)*eh(ih) -

     &    vmix(2,2)*umix(1,1)*dh(ih))/sr2

          f12k=(vmix(1,1)*umix(2,2)*eh(ih) -

     &    vmix(1,2)*umix(2,1)*dh(ih))/sr2

          xmk=xmj*etah(ih)

          xlam(lknt)=pyx2xh(c1,xmi,xmk,xmh,f12k,f21k)

          idlam(lknt,1)=kfcchi(1)

          idlam(lknt,2)=ith(ih)

          idlam(lknt,3)=0

        ENDIF

  140 CONTINUE


C...CHI1 JUMPS TO HERE

  150 CONTINUE


C...CHI+_I -> CHI0_J + W+

      DO 180 ij=1,4

        xmj=smz(ij)

        axmj=abs(xmj)

        xmj2=xmj**2

        IF(axmi.GE.axmj+xmw) THEN

          lknt=lknt+1

          gl=zmix(ij,2)*vmix(ix,1)-zmix(ij,4)*vmix(ix,2)/sr2

          gr=zmix(ij,2)*umix(ix,1)+zmix(ij,3)*umix(ix,2)/sr2

          xlam(lknt)=pyx2xg(c1/xmw2,xmi,xmj,xmw,gl,gr)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=24

          idlam(lknt,3)=0


C...LEPTONS

        ELSEIF(axmi.GE.axmj) THEN

          xmf1=0d0

          xmf2=0d0

          s12min=(xmf1+xmf2)**2

          s12max=(axmj-axmi)**2

          xxm(5)=-1d0/sr2*zmix(ij,4)*vmix(ix,2)+zmix(ij,2)*vmix(ix,1)

          xxm(6)= 1d0/sr2*zmix(ij,3)*umix(ix,2)+zmix(ij,2)*umix(ix,1)

          fid=11

          ei=kchg(fid,1)/3d0

          t3=-0.5d0

          xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)

          fid=12

          ei=kchg(fid,1)/3d0

          t3=0.5d0

          xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)


          xxm(4)=xmi

          xxm(1)=xmf1

          xxm(2)=xmj

          xxm(3)=xmf2

          xxm(9)=pmas(24,1)

          xxm(10)=pmas(24,2)

          xxm(11)=pmas(pycomp(ksusy1+11),1)

          xxm(12)=pmas(pycomp(ksusy1+12),1)


C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,

C...--> 1/(16PI)/M**3*(AEM/XW)**2


          IF(xxm(11).LT.axmi) THEN

            xxm(11)=1d6

          ENDIF

          IF(xxm(12).LT.axmi) THEN

            xxm(12)=1d6

          ENDIF

          IF(axmi.GE.axmj+pmas(11,1)+pmas(12,1)) THEN

            lknt=lknt+1

            temp=pygaus(pyxxw5,s12min,s12max,prec)

            xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=-11

            idlam(lknt,3)=12


C...ONLY DECAY CHI+1 -> E+ NU_E

            IF( imss(12).NE. 0 ) goto 220

            IF(axmi.GE.axmj+pmas(13,1)+pmas(14,1)) THEN

              lknt=lknt+1

              xxm(11)=pmas(pycomp(ksusy1+13),1)

              xxm(12)=pmas(pycomp(ksusy1+14),1)

              IF(xxm(11).LT.axmi) THEN

                xxm(11)=1d6

              ELSEIF(xxm(12).LT.axmi) THEN

                xxm(12)=1d6

              ENDIF

              temp=pygaus(pyxxw5,s12min,s12max,prec)

              xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp

              idlam(lknt,1)=kfnchi(ij)

              idlam(lknt,2)=-13

              idlam(lknt,3)=14

              IF(axmi.GE.axmj+pmas(15,1)+pmas(16,1)) THEN

                lknt=lknt+1

                IF(abs(sfmix(15,1)).GT.abs(sfmix(15,2))) THEN

                  xxm(11)=pmas(pycomp(ksusy1+15),1)

                ELSE

                  xxm(11)=pmas(pycomp(ksusy2+15),1)

                ENDIF

                xxm(12)=pmas(pycomp(ksusy1+16),1)

                IF(xxm(11).LT.axmi) THEN

                  xxm(11)=1d6

                ENDIF

                IF(xxm(12).LT.axmi) THEN

                  xxm(12)=1d6

                ENDIF

                temp=pygaus(pyxxw5,s12min,s12max,prec)

                xlam(lknt)=c1**2/xmi3/(16d0*pi)*temp

                idlam(lknt,1)=kfnchi(ij)

                idlam(lknt,2)=-15

                idlam(lknt,3)=16

              ENDIF

            ENDIF

          ENDIF


C...NOW, DO THE QUARKS

  160     CONTINUE

          fid=1

          ei=kchg(fid,1)/3d0

          t3=-0.5d0

          xxm(7)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*umix(ix,1)

          fid=1

          ei=kchg(fid,1)/3d0

          t3=0.5d0

          xxm(8)=-sr2*(t3*zmix(ij,2)-tanw*(t3-ei)*zmix(ij,1))*vmix(ix,1)


          xxm(11)=pmas(pycomp(ksusy1+1),1)

          xxm(12)=pmas(pycomp(ksusy1+2),1)

          IF( xxm(11).LT.axmi .AND. xxm(12).LT.axmi ) goto 170

          IF(xxm(11).LT.axmi) THEN

            xxm(11)=1d6

          ELSEIF(xxm(12).LT.axmi) THEN

            xxm(12)=1d6

          ENDIF

          IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN

            lknt=lknt+1

            xlam(lknt)=3d0*c1**2/xmi3/(16d0*pi)*

     &      pygaus(pyxxw5,s12min,s12max,prec)

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=-1

            idlam(lknt,3)=2

            IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN

              lknt=lknt+1

              xlam(lknt)=xlam(lknt-1)

              idlam(lknt,1)=kfnchi(ij)

              idlam(lknt,2)=-3

              idlam(lknt,3)=4

            ENDIF

          ENDIF

  170     CONTINUE

        ENDIF

  180 CONTINUE


C...CHI+_I -> CHI0_J + H+

      DO 190 ij=1,4

        xmj=smz(ij)

        axmj=abs(xmj)

        xmj2=xmj**2

        xmhp=pmas(ithc,1)

        xmhp2=xmhp**2

        IF(axmi.GE.axmj+xmhp) THEN

          lknt=lknt+1

          gl=cbeta*(zmix(ij,4)*vmix(ix,1)+(zmix(ij,2)+

     &    zmix(ij,1)*tanw)*vmix(ix,2)/sr2)

          gr=sbeta*(zmix(ij,3)*umix(ix,1)-(zmix(ij,2)+

     &    zmix(ij,1)*tanw)*umix(ix,2)/sr2)

          xlam(lknt)=pyx2xh(c1,xmi,xmj,xmhp,gl,gr)

          idlam(lknt,1)=kfnchi(ij)

          idlam(lknt,2)=ithc

          idlam(lknt,3)=0

        ELSE


        ENDIF

  190 CONTINUE


C...2-BODY DECAYS TO FERMION SFERMION

      DO 200 j=1,16

        IF(j.GE.7.AND.j.LE.10) goto 200

        IF(mod(j,2).EQ.0) THEN

          kf1=ksusy1+j-1

        ELSE

          kf1=ksusy1+j+1

        ENDIF

        kf2=kf1+ksusy1

        xmsf1=pmas(pycomp(kf1),1)

        xmsf2=pmas(pycomp(kf2),1)

        xmf=pmas(j,1)

        IF(j.LE.6) THEN

          fcol=3d0

        ELSE

          fcol=1d0

        ENDIF


C...U~ D_L

        IF(mod(j,2).EQ.0) THEN

          xmfp=pmas(j-1,1)

          al=umix(ix,1)

          bl=-xmf*vmix(ix,2)/xmw/sbeta/sr2

          ar=-xmfp*umix(ix,2)/xmw/cbeta/sr2

          br=0d0

          isf=j-1

        ELSE

          xmfp=pmas(j+1,1)

          al=vmix(ix,1)

          bl=-xmf*umix(ix,2)/xmw/cbeta/sr2

          br=0d0

          ar=-xmfp*vmix(ix,2)/xmw/sbeta/sr2

          isf=j+1

        ENDIF


C...~U_L D

        IF(axmi.GE.xmf+xmsf1) THEN

          lknt=lknt+1

          xma2=xmsf1**2

          xmb2=xmf**2

          xl=pylamf(xmi2,xma2,xmb2)

          ca=al*sfmix(isf,1)+ar*sfmix(isf,2)

          cb=bl*sfmix(isf,1)+br*sfmix(isf,2)

          xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*

     &    (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)

          idlam(lknt,3)=0

          IF(mod(j,2).EQ.0) THEN

            idlam(lknt,1)=-kf1

            idlam(lknt,2)=j

          ELSE

            idlam(lknt,1)=kf1

            idlam(lknt,2)=-j

          ENDIF

        ENDIF


C...U~ D_R

        IF(axmi.GE.xmf+xmsf2) THEN

          lknt=lknt+1

          xma2=xmsf2**2

          xmb2=xmf**2

          ca=al*sfmix(isf,3)+ar*sfmix(isf,4)

          cb=bl*sfmix(isf,3)+br*sfmix(isf,4)

          xl=pylamf(xmi2,xma2,xmb2)

          xlam(lknt)=fcol*c1/8d0/xmi3*sqrt(xl)*( (xmi2+xmb2-xma2)*

     &    (ca**2+cb**2)+4d0*ca*cb*xmf*xmi)

          idlam(lknt,3)=0

          IF(mod(j,2).EQ.0) THEN

            idlam(lknt,1)=-kf2

            idlam(lknt,2)=j

          ELSE

            idlam(lknt,1)=kf2

            idlam(lknt,2)=-j

          ENDIF

        ENDIF

  200 CONTINUE


C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH

C...A 2-BODY -- 2-BODY CHAIN

      xmj=pmas(pycomp(ksusy1+21),1)

      IF(axmi.GE.xmj) THEN

        axmj=abs(xmj)

        s12min=0d0

        s12max=(axmi-axmj)**2

        xxm(1)=0d0

        xxm(2)=xmj

        xxm(3)=0d0

        xxm(4)=xmi

        xxm(5)=0d0

        xxm(6)=0d0

        xxm(9)=1d6

        xxm(10)=0d0

        xxm(7)=umix(ix,1)*sr2

        xxm(8)=vmix(ix,1)*sr2

        xxm(11)=pmas(pycomp(ksusy1+1),1)

        xxm(12)=pmas(pycomp(ksusy1+2),1)

        IF( xxm(11).LT.axmi .OR. xxm(12).LT.axmi ) goto 210

        IF(axmi.GE.axmj+pmas(1,1)+pmas(2,1)) THEN

          lknt=lknt+1

          xlam(lknt)=4d0*c1*as/xmi3/(16d0*pi)*

     &    pygaus(pyxxw5,s12min,s12max,prec)

          idlam(lknt,1)=ksusy1+21

          idlam(lknt,2)=-1

          idlam(lknt,3)=2

          IF(axmi.GE.axmj+pmas(3,1)+pmas(4,1)) THEN

            lknt=lknt+1

            xlam(lknt)=xlam(lknt-1)

            idlam(lknt,1)=ksusy1+21

            idlam(lknt,2)=-3

            idlam(lknt,3)=4

          ENDIF

        ENDIF

  210   CONTINUE

      ENDIF


  220 iknt=lknt

      xlam(0)=0d0

      DO 230 i=1,iknt

        xlam(0)=xlam(0)+xlam(i)

        IF(xlam(i).LT.0d0) THEN

          WRITE(mstu(11),*) ' XLAM(I) = ',xlam(i),kcin,

     &    (idlam(i,j),j=1,3)

          xlam(i)=0d0

        ENDIF

  230 CONTINUE

      IF(xlam(0).EQ.0d0) THEN

        xlam(0)=1d-6

        WRITE(mstu(11),*) ' XLAM(0) = ',xlam(0)

        WRITE(mstu(11),*) lknt

        WRITE(mstu(11),*) (xlam(j),j=1,lknt)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYXXZ5

C...Calculates chi0 -> chi0 + f + ~f.


      FUNCTION pyxxz5(X)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pyints/


C...Local variables.

      DOUBLE PRECISION pyxxz5,x

      DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,wprop2

      DOUBLE PRECISION ww,wf1,wf2,wfl1,wfl2

      DOUBLE PRECISION sij

      DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsu,xmsd

      DOUBLE PRECISION le,re,le2,re2,ol2,or2,fli,flj,fri,frj

      DOUBLE PRECISION s23min,s23max,s23ave,s23del

      INTEGER i

      DATA sr2/1.4142136d0/


C...Statement functions.

C...Integral from x to y of (t-a)(b-t) dt.

      tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)

C...Integral from x to y of (t-a)(b-t)/(t-c) dt.

      tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-

     &log(abs((x-c)/(y-c)))*(c-b)*(c-a)

C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.

      tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+

     &(b+a-2d0*c)*log(abs((x-c)/(y-c)))

C...Integral from x to y of (t-a)/(b-t) dt.

      utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)

C...Integral from x to y of 1/(t-a) dt.

      tprop(x,y,a)=log(abs((x-a)/(y-a)))


      xm12=xxm(1)**2

      xm22=xxm(2)**2

      xm32=xxm(3)**2

      s=xxm(4)**2

      s13=x


      s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)

      s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*

     &( (x-xm22-s)**2  -4d0*xm22*s  ) )


      s23min=(s23ave-s23del)

      s23max=(s23ave+s23del)


      xmv=xxm(7)

      xmg=xxm(8)

      xmsd=xxm(5)**2

      xmsu=xxm(6)**2

      ol=xxm(9)

      or=xxm(10)

      ol2=ol**2

      or2=or**2

      le=xxm(11)

      re=xxm(12)

      le2=le**2

      re2=re**2

      fli=xxm(13)

      flj=xxm(14)

      fri=xxm(15)

      frj=xxm(16)


      wprop2=(s13-xmv**2)**2+(xmv*xmg)**2

      sij=2d0*xxm(2)*xxm(4)*s13


      IF(xmv.LE.1000d0) THEN

        ww=2d0*(le2+re2)*(ol2)*( 2d0*tint(s23max,s23min,xm22,s)

     &  +sij*(s23max-s23min) )/wprop2

        IF(xxm(5).LE.10000d0) THEN

          wfl1=2d0*fli*flj*ol*le*( 2d0*tint2(s23max,s23min,xm22,s,xmsd)

     &    + sij*tprop(s23max,s23min,xmsd) )

          wfl1=wfl1*(s13-xmv**2)/wprop2

        ELSE

          wfl1=0d0

        ENDIF

        IF(xxm(6).LE.10000d0) THEN

          wfl2=2d0*fri*frj*or*re*( 2d0*tint2(s23max,s23min,xm22,s,xmsu)

     &    + sij*tprop(s23max,s23min,xmsu) )

          wfl2=wfl2*(s13-xmv**2)/wprop2

        ELSE

          wfl2=0d0

        ENDIF

      ELSE

        ww=0d0

        wfl1=0d0

        wfl2=0d0

      ENDIF

      IF(xxm(5).LE.10000d0) THEN

        wf1=0.5d0*(fli*flj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsd)

     &  + sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsd) )

      ELSE

        wf1=0d0

      ENDIF

      IF(xxm(6).LE.10000d0) THEN

        wf2=0.5d0*(fri*frj)**2*( 2d0*tint3(s23max,s23min,xm22,s,xmsu)

     &  + sij*utint(s23max,s23min,xmsu,xm22+s-s13-xmsu) )

      ELSE

        wf2=0d0

      ENDIF


C...WFL1=0.0

C...WFL2=0.0

      pyxxz5=(ww+wf1+wf2+wfl1+wfl2)

      IF(pyxxz5.LT.0d0) THEN

        WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ5 '

        WRITE(mstu(11),*) xxm(1),xxm(2),xxm(3),xxm(4)

        WRITE(mstu(11),*) (xxm(i),i=5,8)

        WRITE(mstu(11),*) (xxm(i),i=9,12)

        WRITE(mstu(11),*) (xxm(i),i=13,16)

        WRITE(mstu(11),*) ww,wf1,wf2,wfl1,wfl2

        WRITE(mstu(11),*) s23min,s23max

        pyxxz5=0d0

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYXXW5

C...Calculates chi0(+) -> chi+(0) + f + ~f'.


      FUNCTION pyxxw5(X)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pyints/


C...Local variables.

      DOUBLE PRECISION pyxxw5,x

      DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,s12,wprop2

      DOUBLE PRECISION ww,wu,wd,wwu,wwd,wud

      DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsd,xmsu

      DOUBLE PRECISION sij

      DOUBLE PRECISION s23min,s23max,s23ave,s23del

      INTEGER ik

      SAVE ik

      DATA ik/0/

      DATA sr2/1.4142136d0/


C...Statement functions.

C...Integral from x to y of (t-a)(b-t) dt.

      tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)

C...Integral from x to y of (t-a)(b-t)/(t-c) dt.

      tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-

     &log(abs((x-c)/(y-c)))*(c-b)*(c-a)

C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.

      tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+

     &(b+a-2d0*c)*log(abs((x-c)/(y-c)))

C...Integral from x to y of (t-a)/(b-t) dt.

      utint(x,y,a,b)=log(abs((x-a)/(b-x)*(b-y)/(y-a)))/(b-a)

C...Integral from x to y of 1/(t-a) dt.

      tprop(x,y,a)=log(abs((x-a)/(y-a)))


      xm12=xxm(1)**2

      xm22=xxm(2)**2

      xm32=xxm(3)**2

      s=xxm(4)**2

      s13=x

      IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN

        s23ave=0.5d0*(xm22+s-s13)

        s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )

      ELSE

        s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)

        s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*

     &  ( (x-xm22-s)**2  -4d0*xm22*s  ) )

      ENDIF

      s23min=(s23ave-s23del)

      s23max=(s23ave+s23del)

      IF(s23del.LT.1d-3) THEN

        pyxxw5=0d0

        RETURN

      ENDIF

      xmv=xxm(9)

      xmg=xxm(10)

      xmsd=xxm(11)**2

      xmsu=xxm(12)**2

      ol=xxm(5)

      or=xxm(6)

      fld=xxm(7)

      flu=xxm(8)


      wprop2=((s13-xmv**2)**2+(xmv*xmg)**2)

      sij=s13*xxm(2)*xxm(4)

      IF(xmv.LE.1000d0) THEN

        ww=(or**2+ol**2)*tint(s23max,s23min,xm22,s)

     &  -2d0*ol*or*sij*(s23max-s23min)

        ww=ww/wprop2

        IF(xxm(11).LE.10000d0) THEN

          wwd=ol*sij*tprop(s23max,s23min,xmsd)

     &    -or*tint2(s23max,s23min,xm22,s,xmsd)

          wwd=-wwd*sr2*fld

          wwd=wwd*(s13-xmv**2)/wprop2

        ELSE

          wwd=0d0

        ENDIF

        IF(xxm(12).LE.10000d0) THEN

          wwu=or*sij*tprop(s23max,s23min,xmsu)

     &    -ol*tint2(s23max,s23min,xm22,s,xmsu)

          wwu=wwu*sr2*flu

          wwu=wwu*(s13-xmv**2)/wprop2

        ELSE

          wwu=0d0

        ENDIF

      ELSE

        ww=0d0

        wwd=0d0

        wwu=0d0

      ENDIF

      IF(xxm(12).LE.10000d0) THEN

        wu=0.5d0*flu**2*tint3(s23max,s23min,xm22,s,xmsu)

      ELSE

        wu=0d0

      ENDIF

      IF(xxm(11).LE.10000d0) THEN

        wd=0.5d0*fld**2*tint3(s23max,s23min,xm22,s,xmsd)

      ELSE

        wd=0d0

      ENDIF

      IF(xxm(11).LE.10000d0.AND.xxm(12).LE.10000d0) THEN

        wud=flu*fld*sij*utint(s23max,s23min,xmsd,xm22+s-s13-xmsu)

      ELSE

        wud=0d0

      ENDIF


      pyxxw5=ww+wu+wd+wwu+wwd+wud


      IF(pyxxw5.LT.0d0) THEN

        IF(ik.EQ.0) THEN

          WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXW5 '

          WRITE(mstu(11),*) ww,wu,wd

          WRITE(mstu(11),*) wwd,wwu,wud

          WRITE(mstu(11),*) sqrt(s13)

          WRITE(mstu(11),*) tint(s23max,s23min,xm22,s)

          ik=1

        ENDIF

        pyxxw5=0d0

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYXXGA

C...Calculates chi0_i -> chi0_j + gamma.


      FUNCTION pyxxga(C0,XM1,XM2,XMTR,XMTL)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION pyxxga,c0,xm1,xm2,xmtr,xmtl

      DOUBLE PRECISION f1,f2


      f1=(1d0+xmtr/(1d0-xmtr)*log(xmtr))/(1d0-xmtr)

      f2=(1d0+xmtl/(1d0-xmtl)*log(xmtl))/(1d0-xmtl)

      pyxxga=c0*((xm1**2-xm2**2)/xm1)**3

      pyxxga=pyxxga*(2d0/3d0*(f1+f2)-13d0/12d0)**2


      RETURN

      END


C*********************************************************************


C...PYX2XG

C...Calculates the decay rate for ino -> ino + gauge boson.


      FUNCTION pyx2xg(C1,XM1,XM2,XM3,GL,GR)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION pyx2xg,xm1,xm2,xm3,gl,gr

      DOUBLE PRECISION xl,pylamf,c1

      DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3


      xmi2=xm1**2

      xmi3=abs(xm1**3)

      xmj2=xm2**2

      xmv2=xm3**2

      xl=pylamf(xmi2,xmj2,xmv2)

      pyx2xg=c1/8d0/xmi3*sqrt(xl)

     &*((gl**2+gr**2)*(xl+3d0*xmv2*(xmi2+xmj2-xmv2))-

     &12d0*gl*gr*xm1*xm2*xmv2)


      RETURN

      END


C*********************************************************************


C...PYX2XH

C...Calculates the decay rate for ino -> ino + H.


      FUNCTION pyx2xh(C1,XM1,XM2,XM3,GL,GR)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION pyx2xh,xm1,xm2,xm3,gl,gr

      DOUBLE PRECISION xl,pylamf,c1

      DOUBLE PRECISION xmi2,xmj2,xmv2,xmi3


      xmi2=xm1**2

      xmi3=abs(xm1**3)

      xmj2=xm2**2

      xmv2=xm3**2

      xl=pylamf(xmi2,xmj2,xmv2)

      pyx2xh=c1/8d0/xmi3*sqrt(xl)

     &*((gl**2+gr**2)*(xmi2+xmj2-xmv2)+

     &4d0*gl*gr*xm1*xm2)


      RETURN

      END


C*********************************************************************


C...PYXXZ2

C...Calculates chi+ -> chi+ + f + ~f.


      FUNCTION pyxxz2(X)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyints/xxm(20)

      SAVE /pydat1/,/pyints/


C...Local variables.

      DOUBLE PRECISION pyxxz2,x

      DOUBLE PRECISION xm12,xm22,xm32,s,s23,s13,s12,wprop2

      DOUBLE PRECISION ww,wu,wd,wwu,wwd,wud

      DOUBLE PRECISION sr2,ol,or,fld,flu,xmv,xmg,xmsl

      DOUBLE PRECISION sij

      DOUBLE PRECISION le,re,le2,re2,ol2,or2,ct

      DOUBLE PRECISION s23min,s23max,s23ave,s23del

      INTEGER i

      DATA sr2/1.4142136d0/


C...Statement functions.

C...Integral from x to y of (t-a)(b-t) dt.

      tint(x,y,a,b)=(x-y)*(-(x**2+x*y+y**2)/3d0+(b+a)*(x+y)/2d0-a*b)

C...Integral from x to y of (t-a)(b-t)/(t-c) dt.

      tint2(x,y,a,b,c)=(x-y)*(-0.5d0*(x+y)+(b+a-c))-

     &log(abs((x-c)/(y-c)))*(c-b)*(c-a)

C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.

      tint3(x,y,a,b,c)=-(x-y)+(c-a)*(c-b)*(y-x)/(x-c)/(y-c)+

     &(b+a-2d0*c)*log(abs((x-c)/(y-c)))

C...Integral from x to y of 1/(t-a) dt.

      tprop(x,y,a)=log(abs((x-a)/(y-a)))


      xm12=xxm(1)**2

      xm22=xxm(2)**2

      xm32=xxm(3)**2

      s=xxm(4)**2

      s13=x

      IF(xxm(1).EQ.0.AND.xxm(3).EQ.0d0) THEN

        s23ave=0.5d0*(xm22+s-s13)

        s23del=0.5d0*sqrt( (x-xm22-s)**2-4d0*xm22*s )

      ELSE

        s23ave=xm22+xm32-0.5d0/x*(x+xm32-xm12)*(x+xm22-s)

        s23del=0.5d0/x*sqrt( ( (x-xm12-xm32)**2-4d0*xm12*xm32)*

     &  ( (x-xm22-s)**2  -4d0*xm22*s  ) )

      ENDIF

      s23min=(s23ave-s23del)

      s23max=(s23ave+s23del)

      IF(s23del.LT.1d-3) THEN

        pyxxz2=0d0

        RETURN

      ENDIF


      xmv=xxm(9)

      xmg=xxm(10)

      xmsl=xxm(11)**2

      ol=xxm(5)

      or=xxm(6)

      ol2=ol**2

      or2=or**2

      le=xxm(7)

      re=xxm(8)

      le2=le**2

      re2=re**2

      ct=xxm(12)


      wprop2=(s13-xmv**2)**2+(xmv*xmg)**2

      sij=xxm(2)*xxm(4)*s13

      ww=(le2+re2)*(or2+ol2)*2d0*tint(s23max,s23min,xm22,s)

     &- 4d0*(le2+re2)*ol*or*sij*(s23max-s23min)

      ww=ww/wprop2

      IF(xmsl.GT.1d4*s) THEN

        wd=0d0

        wwd=0d0

      ELSE

        wd=0.5d0*ct**2*tint3(s23max,s23min,xm22,s,xmsl)

        wwd=ol*tint2(s23max,s23min,xm22,s,xmsl)-

     &  or*sij*tprop(s23max,s23min,xmsl)

        wwd=2d0*wwd*le*ct*(s13-xmv**2)/wprop2

      ENDIF


      pyxxz2=(ww+wd+wwd)

      IF(pyxxz2.LT.0d0) THEN

        WRITE(mstu(11),*) ' NEGATIVE WT IN PYXXZ2 '

        WRITE(mstu(11),*) ww,wd,wwd

        WRITE(mstu(11),*) s23min,s23max

        WRITE(mstu(11),*) (xxm(i),i=1,4)

        WRITE(mstu(11),*) (xxm(i),i=5,8)

        WRITE(mstu(11),*) (xxm(i),i=9,12)

        pyxxz2=0d0

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYHEXT

C...Calculates the non-standard decay modes of the Higgs boson.


      SUBROUTINE pyhext(KFIN,XLAM,IDLAM,IKNT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pymssm/imss(0:99),rmss(0:99)

      common/pyssmt/zmix(4,4),umix(2,2),vmix(2,2),smz(4),smw(2),

     &sfmix(16,4)

      SAVE /pydat1/,/pydat2/,/pypars/,/pymssm/,/pyssmt/


C...Local variables.

      INTEGER kfin

      DOUBLE PRECISION xmi,xmj,xmf,xmsf1,xmsf2,xmw,xmw2,

     &xmz,xmz2,axmj,axmi

      DOUBLE PRECISION xmfp,xmf1,xmf2,xmsl,xmg

      DOUBLE PRECISION s12min,s12max

      DOUBLE PRECISION xmi2,xmi3,xmj2,xmh,xmh2,xmhp,xmhp2,xma2,xmb2

      DOUBLE PRECISION pylamf,xl,cf,ei

      INTEGER idu,ic,ilr,ifl

      DOUBLE PRECISION tanw,xw,aem,c1,as

      DOUBLE PRECISION pyh2xx,ghll,ghrr,ghlr

      DOUBLE PRECISION xlam(0:200)

      INTEGER idlam(200,3)

      INTEGER lknt,ix,ih,j,ij,i,iknt,ik

      INTEGER ith(4)

      INTEGER kfnchi(4),kfcchi(2)

      DOUBLE PRECISION etah(3),ch(3),dh(3),eh(3)

      DOUBLE PRECISION sr2

      DOUBLE PRECISION beta,alfa

      DOUBLE PRECISION cbeta,sbeta,gr,gl,f12k,f21k,tanb

      DOUBLE PRECISION pyalem,pi,pyalps

      DOUBLE PRECISION al,bl,ar,br,alp,arp,blp,brp,alr

      DOUBLE PRECISION xmk,axmk,xmk2,cosa,sina,cw,xml

      DOUBLE PRECISION xmuz,atrit,atrib,atril

      DOUBLE PRECISION xmjl,xmjr,xm1,xm2

      DATA ith/25,35,36,37/

      DATA etah/1d0,1d0,-1d0/

      DATA sr2/1.4142136d0/

      DATA pi/3.141592654d0/

      DATA kfnchi/1000022,1000023,1000025,1000035/

      DATA kfcchi/1000024,1000037/


C...COUNT THE NUMBER OF DECAY MODES

      lknt=iknt


      xmw=pmas(24,1)

      xmw2=xmw**2

      xmz=pmas(23,1)

      xmz2=xmz**2

      xw=paru(102)

      tanw = sqrt(xw/(1d0-xw))

      cw=sqrt(1d0-xw)


C...1 - 4 DEPENDING ON Higgs species.

      ih=1

      IF(kfin.EQ.ith(2)) ih=2

      IF(kfin.EQ.ith(3)) ih=3

      IF(kfin.EQ.ith(4)) ih=4


      xmi=pmas(kfin,1)

      xmi2=xmi**2

      axmi=abs(xmi)

      aem=pyalem(xmi2)

      as =pyalps(xmi2)

      c1=aem/xw

      xmi3=abs(xmi**3)


      tanb=rmss(5)

      beta=atan(tanb)

      cbeta=cos(beta)

      sbeta=tanb*cbeta

      alfa=rmss(18)

      cosa=cos(alfa)

      sina=sin(alfa)

      atrit=rmss(16)

      atrib=rmss(15)

      atril=rmss(17)

      xmuz=-rmss(4)


      IF(ih.EQ.4) goto 180


C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS

C...H0_K -> CHI0_I + CHI0_J

      eh(1)=sina

      eh(2)=cosa

      eh(3)=-sbeta

      dh(1)=cosa

      dh(2)=-sina

      dh(3)=cbeta

      DO 110 ij=1,4

        xmj=smz(ij)

        axmj=abs(xmj)

        DO 100 ik=1,ij

          xmk=smz(ik)

          axmk=abs(xmk)

          IF(axmi.GE.axmj+axmk) THEN

            lknt=lknt+1

            f21k=0.5d0*

     &      eh(ih)*( zmix(ik,3)*zmix(ij,2)+zmix(ij,3)*zmix(ik,2)

     &      -tanw*(zmix(ik,3)*zmix(ij,1)+zmix(ij,3)*zmix(ik,1)) )+

     &      0.5d0*dh(ih)*( zmix(ik,4)*zmix(ij,2)+zmix(ij,4)*zmix(ik,2)

     &      -tanw*(zmix(ik,4)*zmix(ij,1)+zmix(ij,4)*zmix(ik,1)) )

            f12k=0.5d0*

     &      eh(ih)*(zmix(ij,3)*zmix(ik,2)+zmix(ik,3)*zmix(ij,2)

     &      -tanw*(zmix(ij,3)*zmix(ik,1)+zmix(ik,3)*zmix(ij,1)))+

     &      0.5d0*dh(ih)*( zmix(ij,4)*zmix(ik,2)+zmix(ik,4)*zmix(ij,2)

     &      -tanw*(zmix(ij,4)*zmix(ik,1)+zmix(ik,4)*zmix(ij,1)) )

C...SIGN OF MASSES I,J

            xml=xmk*etah(ih)

            xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)

            IF(ij.EQ.ik) xlam(lknt)=xlam(lknt)*0.5d0

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=kfnchi(ik)

            idlam(lknt,3)=0

          ENDIF

  100   CONTINUE

  110 CONTINUE


C...H0_K -> CHI+_I CHI-_J

      DO 130 ij=1,2

        xmj=smw(ij)

        axmj=abs(xmj)

        DO 120 ik=1,2

          xmk=smw(ik)

          axmk=abs(xmk)

          IF(axmi.GE.axmj+axmk) THEN

            lknt=lknt+1

            f21k=(vmix(ij,1)*umix(ik,2)*eh(ih) -

     &      vmix(ij,2)*umix(ik,1)*dh(ih))/sr2

            f12k=(vmix(ik,1)*umix(ij,2)*eh(ih) -

     &      vmix(ik,2)*umix(ij,1)*dh(ih))/sr2

            xml=-xmk*etah(ih)

            xlam(lknt)=pyh2xx(c1,xmi,xmj,xml,f12k,f21k)

            idlam(lknt,1)=kfcchi(ij)

            idlam(lknt,2)=-kfcchi(ik)

            idlam(lknt,3)=0

          ENDIF

  120   CONTINUE

  130 CONTINUE


C...HIGGS TO SFERMION SFERMION

      DO 160 ifl=1,16

        IF(ifl.GE.7.AND.ifl.LE.10) goto 160

        ij=ksusy1+ifl

        xmjl=pmas(pycomp(ij),1)

        xmjr=pmas(pycomp(ij+ksusy1),1)

        IF(axmi.GE.2d0*min(xmjl,xmjr)) THEN

          xmj=xmjl

          xmj2=xmj**2

          xl=pylamf(xmi2,xmj2,xmj2)

          xmf=pmas(ifl,1)

          ei=kchg(ifl,1)/3d0

          idu=2-mod(ifl,2)


          IF(ih.EQ.1) THEN

            IF(idu.EQ.1) THEN

              ghll=-xmz/cw*(0.5d0+ei*xw)*sin(alfa+beta)+

     &        xmf**2/xmw*sina/cbeta

              ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)+

     &        xmf**2/xmw*sina/cbeta

              IF(ifl.EQ.5) THEN

                ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-

     &          atrib*sina)

              ELSEIF(ifl.EQ.15) THEN

                ghlr=-xmf/2d0/xmw/cbeta*(xmuz*cosa-

     &          atril*sina)

              ELSE

                ghlr=0d0

              ENDIF

            ELSE

              ghll=xmz/cw*(0.5d0-ei*xw)*sin(alfa+beta)-

     &        xmf**2/xmw*cosa/sbeta

              ghrr=xmz/cw*(ei*xw)*sin(alfa+beta)-

     &        xmf**2/xmw*cosa/sbeta

              IF(ifl.EQ.6) THEN

                ghlr=xmf/2d0/xmw/sbeta*(xmuz*sina-

     &          atrit*cosa)

              ELSE

                ghlr=0d0

              ENDIF

            ENDIF


          ELSEIF(ih.EQ.2) THEN

            IF(idu.EQ.1) THEN

              ghll=xmz/cw*(0.5d0+ei*xw)*cos(alfa+beta)-

     &        xmf**2/xmw*cosa/cbeta

              ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-

     &        xmf**2/xmw*cosa/cbeta

              IF(ifl.EQ.5) THEN

                ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+

     &          atrib*cosa)

              ELSEIF(ifl.EQ.15) THEN

                ghlr=-xmf/2d0/xmw/cbeta*(xmuz*sina+

     &          atril*cosa)

              ELSE

                ghlr=0d0

              ENDIF

            ELSE

              ghll=-xmz/cw*(0.5d0-ei*xw)*cos(alfa+beta)-

     &        xmf**2/xmw*sina/sbeta

              ghrr=-xmz/cw*(ei*xw)*cos(alfa+beta)-

     &        xmf**2/xmw*sina/sbeta

              IF(ifl.EQ.6) THEN

                ghlr=-xmf/2d0/xmw/sbeta*(xmuz*cosa+

     &          atrit*sina)

              ELSE

                ghlr=0d0

              ENDIF

            ENDIF


          ELSEIF(ih.EQ.3) THEN

            ghll=0d0

            ghrr=0d0

            ghlr=0d0

            IF(idu.EQ.1) THEN

              IF(ifl.EQ.5) THEN

                ghlr=xmf/2d0/xmw*(atrib*tanb-xmuz)

              ELSEIF(ifl.EQ.15) THEN

                ghlr=xmf/2d0/xmw*(atril*tanb-xmuz)

              ENDIF

            ELSE

              IF(ifl.EQ.6) THEN

                ghlr=xmf/2d0/xmw*(atrit/tanb-xmuz)

              ENDIF

            ENDIF

          ENDIF

          IF(ih.EQ.3) goto 140


          al=sfmix(ifl,1)**2

          ar=sfmix(ifl,2)**2

          alr=sfmix(ifl,1)*sfmix(ifl,2)

          IF(ifl.LE.6) THEN

            cf=3d0

          ELSE

            cf=1d0

          ENDIF


          IF(axmi.GE.2d0*xmj) THEN

            lknt=lknt+1

            xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &      (ghll*al+ghrr*ar

     &      +2d0*ghlr*alr)**2

            idlam(lknt,1)=ij

            idlam(lknt,2)=-ij

            idlam(lknt,3)=0

          ENDIF


          IF(axmi.GE.2d0*xmjr) THEN

            lknt=lknt+1

            al=sfmix(ifl,3)**2

            ar=sfmix(ifl,4)**2

            alr=sfmix(ifl,3)*sfmix(ifl,4)

            xmj=xmjr

            xmj2=xmj**2

            xl=pylamf(xmi2,xmj2,xmj2)

            xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &      (ghll*al+ghrr*ar

     &      +2d0*ghlr*alr)**2

            idlam(lknt,1)=ij+ksusy1

            idlam(lknt,2)=-(ij+ksusy1)

            idlam(lknt,3)=0

          ENDIF

  140     CONTINUE


          IF(axmi.GE.xmjl+xmjr) THEN

            lknt=lknt+1

            al=sfmix(ifl,1)*sfmix(ifl,3)

            ar=sfmix(ifl,2)*sfmix(ifl,4)

            alr=sfmix(ifl,1)*sfmix(ifl,4)+sfmix(ifl,2)*sfmix(ifl,3)

            xmj=xmjr

            xmj2=xmj**2

            xl=pylamf(xmi2,xmj2,xmjl**2)

            xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &      (ghll*al+ghrr*ar)**2

            idlam(lknt,1)=ij

            idlam(lknt,2)=-(ij+ksusy1)

            idlam(lknt,3)=0

            lknt=lknt+1

            idlam(lknt,1)=-ij

            idlam(lknt,2)=ij+ksusy1

            idlam(lknt,3)=0

            xlam(lknt)=xlam(lknt-1)

          ENDIF

        ENDIF

  150   CONTINUE

  160 CONTINUE

  170 CONTINUE


      goto 230

  180 CONTINUE


C...H+ -> CHI+_I + CHI0_J

      DO 200 ij=1,4

        xmj=smz(ij)

        axmj=abs(xmj)

        xmj2=xmj**2

        DO 190 ik=1,2

          xmk=smw(ik)

          axmk=abs(xmk)

          xmk2=xmk**2

          IF(axmi.GE.axmj+axmk) THEN

            lknt=lknt+1

            gl=cbeta*(zmix(ij,4)*vmix(ik,1)+(zmix(ij,2)+zmix(ij,1)*

     &      tanw)*vmix(ik,2)/sr2)

            gr=sbeta*(zmix(ij,3)*umix(ik,1)-(zmix(ij,2)+zmix(ij,1)*

     &      tanw)*umix(ik,2)/sr2)

            xlam(lknt)=pyh2xx(c1,xmi,xmj,-xmk,gl,gr)

            idlam(lknt,1)=kfnchi(ij)

            idlam(lknt,2)=kfcchi(ik)

            idlam(lknt,3)=0

          ENDIF

  190   CONTINUE

  200 CONTINUE


      gl=-xmw/sr2*(sin(2d0*beta)-pmas(6,1)**2/tanb/xmw2)

      gr=-pmas(6,1)/sr2/xmw*(xmuz-atrit/tanb)

      al=0d0

      ar=0d0

      cf=3d0


C...H+ -> T_1 B_1~

      xm1=pmas(pycomp(ksusy1+6),1)

      xm2=pmas(pycomp(ksusy1+5),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &  (gl*sfmix(6,1)*sfmix(5,1)+gr*sfmix(6,2)*sfmix(5,1))**2

        idlam(lknt,1)=ksusy1+6

        idlam(lknt,2)=-(ksusy1+5)

        idlam(lknt,3)=0

      ENDIF


C...H+ -> T_2 B_1~

      xm1=pmas(pycomp(ksusy2+6),1)

      xm2=pmas(pycomp(ksusy1+5),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &  (gl*sfmix(6,3)*sfmix(5,1)+gr*sfmix(6,4)*sfmix(5,1))**2

        idlam(lknt,1)=ksusy2+6

        idlam(lknt,2)=-(ksusy1+5)

        idlam(lknt,3)=0

      ENDIF


C...H+ -> T_1 B_2~

      xm1=pmas(pycomp(ksusy1+6),1)

      xm2=pmas(pycomp(ksusy2+5),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &  (gl*sfmix(6,1)*sfmix(5,3)+gr*sfmix(6,2)*sfmix(5,3))**2

        idlam(lknt,1)=ksusy1+6

        idlam(lknt,2)=-(ksusy2+5)

        idlam(lknt,3)=0

      ENDIF


C...H+ -> T_2 B_2~

      xm1=pmas(pycomp(ksusy2+6),1)

      xm2=pmas(pycomp(ksusy2+5),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*

     &  (gl*sfmix(6,3)*sfmix(5,3)+gr*sfmix(6,4)*sfmix(5,3))**2

        idlam(lknt,1)=ksusy2+6

        idlam(lknt,2)=-(ksusy2+5)

        idlam(lknt,3)=0

      ENDIF


C...H+ -> UL DL~

      gl=-xmw/sr2*sin(2d0*beta)

      DO 210 ij=1,3,2

        xm1=pmas(pycomp(ksusy1+ij),1)

        xm2=pmas(pycomp(ksusy1+ij+1),1)

        IF(xmi.GE.xm1+xm2) THEN

          xl=pylamf(xmi2,xm1**2,xm2**2)

          lknt=lknt+1

          xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2

          idlam(lknt,1)=-(ksusy1+ij)

          idlam(lknt,2)=ksusy1+ij+1

          idlam(lknt,3)=0

        ENDIF

  210 CONTINUE


C...H+ -> EL~ NUL

      cf=1d0

      DO 220 ij=11,13,2

        xm1=pmas(pycomp(ksusy1+ij),1)

        xm2=pmas(pycomp(ksusy1+ij+1),1)

        IF(xmi.GE.xm1+xm2) THEN

          xl=pylamf(xmi2,xm1**2,xm2**2)

          lknt=lknt+1

          xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2

          idlam(lknt,1)=-(ksusy1+ij)

          idlam(lknt,2)=ksusy1+ij+1

          idlam(lknt,3)=0

        ENDIF

  220 CONTINUE


C...H+ -> TAU1 NUTAUL

      xm1=pmas(pycomp(ksusy1+15),1)

      xm2=pmas(pycomp(ksusy1+16),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,1)**2

        idlam(lknt,1)=-(ksusy1+15)

        idlam(lknt,2)= ksusy1+16

        idlam(lknt,3)=0

      ENDIF


C...H+ -> TAU2 NUTAUL

      xm1=pmas(pycomp(ksusy2+15),1)

      xm2=pmas(pycomp(ksusy1+16),1)

      IF(xmi.GE.xm1+xm2) THEN

        xl=pylamf(xmi2,xm1**2,xm2**2)

        lknt=lknt+1

        xlam(lknt)=cf*sqrt(xl)/4d0*c1/xmi3*(gl)**2*sfmix(15,3)**2

        idlam(lknt,1)=-(ksusy2+15)

        idlam(lknt,2)= ksusy1+16

        idlam(lknt,3)=0

      ENDIF


  230 CONTINUE

      iknt=lknt

      xlam(0)=0d0

      DO 240 i=1,iknt

        IF(xlam(i).LE.0d0) xlam(i)=0d0

        xlam(0)=xlam(0)+xlam(i)

  240 CONTINUE

      IF(xlam(0).EQ.0d0) xlam(0)=1d-6


      RETURN

      END


C*********************************************************************


C...PYH2XX

C...Calculates the decay rate for a Higgs to an ino pair.


      FUNCTION pyh2xx(C1,XM1,XM2,XM3,GL,GR)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


C...Local variables.

      DOUBLE PRECISION pyh2xx,xm1,xm2,xm3,gl,gr

      DOUBLE PRECISION xl,pylamf,c1

      DOUBLE PRECISION xmi2,xmj2,xmk2,xmi3


      xmi2=xm1**2

      xmi3=abs(xm1**3)

      xmj2=xm2**2

      xmk2=xm3**2

      xl=pylamf(xmi2,xmj2,xmk2)

      pyh2xx=c1/4d0/xmi3*sqrt(xl)

     &*((gl**2+gr**2)*(xmi2-xmj2-xmk2)-

     &4d0*gl*gr*xm3*xm2)

      IF(pyh2xx.LT.0d0) THEN

        WRITE(mstu(11),*) ' NEGATIVE WIDTH IN PYH2XX '

        WRITE(mstu(11),*) xmi2,xmj2,xmk2,gl,gr,xm1,xm2,xm3

        stop

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYGAUS

C...Integration by adaptive Gaussian quadrature.

C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.


      FUNCTION pygaus(F, A, B, EPS)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local declarations.

      EXTERNAL f

      DOUBLE PRECISION w(12), x(12)

      DATA x( 1) /9.6028985649753623d-1/, w( 1) /1.0122853629037626d-1/

      DATA x( 2) /7.9666647741362674d-1/, w( 2) /2.2238103445337447d-1/

      DATA x( 3) /5.2553240991632899d-1/, w( 3) /3.1370664587788729d-1/

      DATA x( 4) /1.8343464249564980d-1/, w( 4) /3.6268378337836198d-1/

      DATA x( 5) /9.8940093499164993d-1/, w( 5) /2.7152459411754095d-2/

      DATA x( 6) /9.4457502307323258d-1/, w( 6) /6.2253523938647893d-2/

      DATA x( 7) /8.6563120238783174d-1/, w( 7) /9.5158511682492785d-2/

      DATA x( 8) /7.5540440835500303d-1/, w( 8) /1.2462897125553387d-1/

      DATA x( 9) /6.1787624440264375d-1/, w( 9) /1.4959598881657673d-1/

      DATA x(10) /4.5801677765722739d-1/, w(10) /1.6915651939500254d-1/

      DATA x(11) /2.8160355077925891d-1/, w(11) /1.8260341504492359d-1/

      DATA x(12) /9.5012509837637440d-2/, w(12) /1.8945061045506850d-1/


C...The Gaussian quadrature algorithm.

      h = 0d0

      IF(b .EQ. a) go to 140

      const = 5d-3 / abs(b-a)

      bb = a

  100 CONTINUE

      aa = bb

      bb = b

  110 CONTINUE

      c1 = 0.5d0*(bb+aa)

      c2 = 0.5d0*(bb-aa)

      s8 = 0d0

      DO 120 i = 1, 4

        u = c2*x(i)

        s8 = s8 + w(i) * (f(c1+u) + f(c1-u))

  120 CONTINUE

      s16 = 0d0

      DO 130 i = 5, 12

        u = c2*x(i)

        s16 = s16 + w(i) * (f(c1+u) + f(c1-u))

  130 CONTINUE

      s16 = c2*s16

      IF(dabs(s16-c2*s8) .LE. eps*(1d0+dabs(s16))) THEN

        h = h + s16

        IF(bb .NE. b) go to 100

      ELSE

        bb = c1

        IF(1d0 + const*abs(c2) .NE. 1d0) go to 110

        h = 0d0

        CALL pyerrm(18,'(PYGAUS:) too high accuracy required')

        go to 140

      ENDIF

  140 CONTINUE

      pygaus = h


      RETURN

      END


C*********************************************************************


C...PYSIMP

C...Simpson formula for an integral.


      FUNCTION pysimp(Y,X0,X1,N)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION y,x0,x1,h,s

      dimension y(0:n)


      s=0d0

      h=(x1-x0)/n

      DO 100 i=0,n-2,2

        s=s+y(i)+4d0*y(i+1)+y(i+2)

  100 CONTINUE

      pysimp=s*h/3d0


      RETURN

      END


C*********************************************************************


C...PYLAMF

C...The standard lambda function.


      FUNCTION pylamf(X,Y,Z)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp


C...Local variables.

      DOUBLE PRECISION pylamf,x,y,z


      pylamf=(x-(y+z))**2-4d0*y*z

      IF(pylamf.LT.0d0) pylamf=0d0


      RETURN

      END


C*********************************************************************


C...PYTBDY

C...Generates 3-body decays of gauginos.


      SUBROUTINE pytbdy(XM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pypars/


C...Local variables.

      DOUBLE PRECISION xm(5)

      DOUBLE PRECISION s12min,s12max,yjaco1,s23ave,s23df1,s23df2

      DOUBLE PRECISION d1,d2,d3,p1,p2,p3,cthe1,sthe1,cthe3,sthe3

      DOUBLE PRECISION cphi1,sphi1

      DOUBLE PRECISION s23del,eps

      DOUBLE PRECISION golden,ax,bx,cx,tol,xmin,r,c

      parameter(r=0.61803399d0,c=1d0-r,tol=1d-3)

      DOUBLE PRECISION f1,f2,x0,x1,x2,x3

      DATA eps/1d-6/


C...GENERATE S12

      s12min=(xm(1)+xm(2))**2

      s12max=(xm(5)-xm(3))**2

      yjaco1=s12max-s12min


C...FIND S12*

      ax=s12min

      cx=s12max

      bx=s12min+0.5d0*yjaco1

      x0=ax

      x3=cx

      IF(abs(cx-bx).GT.abs(bx-ax))THEN

        x1=bx

        x2=bx+c*(cx-bx)

      ELSE

        x2=bx

        x1=bx-c*(bx-ax)

      ENDIF


C...SOLVE FOR F1 AND F2

      s23df1=(x1-xm(2)**2-xm(1)**2)**2

     &-(2d0*xm(1)*xm(2))**2

      s23df2=(x1-xm(3)**2-xm(5)**2)**2

     &-(2d0*xm(3)*xm(5))**2

      s23df1=s23df1*eps

      s23df2=s23df2*eps

      s23del=sqrt(s23df1*s23df2)/(2d0*x1)

      f1=-2d0*s23del/eps

      s23df1=(x2-xm(2)**2-xm(1)**2)**2

     &-(2d0*xm(1)*xm(2))**2

      s23df2=(x2-xm(3)**2-xm(5)**2)**2

     &-(2d0*xm(3)*xm(5))**2

      s23df1=s23df1*eps

      s23df2=s23df2*eps

      s23del=sqrt(s23df1*s23df2)/(2d0*x2)

      f2=-2d0*s23del/eps


  100 IF(abs(x3-x0).GT.tol*(abs(x1)+abs(x2)))THEN

        IF(f2.LT.f1)THEN

          x0=x1

          x1=x2

          x2=r*x1+c*x3

          f1=f2

          s23df1=(x2-xm(2)**2-xm(1)**2)**2

     &    -(2d0*xm(1)*xm(2))**2

          s23df2=(x2-xm(3)**2-xm(5)**2)**2

     &    -(2d0*xm(3)*xm(5))**2

          s23df1=s23df1*eps

          s23df2=s23df2*eps

          s23del=sqrt(s23df1*s23df2)/(2d0*x2)

          f2=-2d0*s23del/eps

        ELSE

          x3=x2

          x2=x1

          x1=r*x2+c*x0

          f2=f1

          s23df1=(x1-xm(2)**2-xm(1)**2)**2

     &    -(2d0*xm(1)*xm(2))**2

          s23df2=(x1-xm(3)**2-xm(5)**2)**2

     &    -(2d0*xm(3)*xm(5))**2

          s23df1=s23df1*eps

          s23df2=s23df2*eps

          s23del=sqrt(s23df1*s23df2)/(2d0*x1)

          f1=-2d0*s23del/eps

        ENDIF

        goto 100

      ENDIF

C...WE WANT THE MAXIMUM, NOT THE MINIMUM

      IF(f1.LT.f2)THEN

        golden=-f1

        xmin=x1

      ELSE

        golden=-f2

        xmin=x2

      ENDIF


      iknt=0

  110 s12=s12min+pyr(0)*yjaco1

      iknt=iknt+1

C...GENERATE S23

      s23ave=xm(2)**2+xm(3)**2-(s12+xm(2)**2-xm(1)**2)

     &*(s12+xm(3)**2-xm(5)**2)/(2d0*s12)

      s23df1=(s12-xm(2)**2-xm(1)**2)**2

     &-(2d0*xm(1)*xm(2))**2

      s23df2=(s12-xm(3)**2-xm(5)**2)**2

     &-(2d0*xm(3)*xm(5))**2

      s23df1=s23df1*eps

      s23df2=s23df2*eps

      s23del=sqrt(s23df1*s23df2)/(2d0*s12)

      s23del=s23del/eps

      s23min=s23ave-s23del

      s23max=s23ave+s23del

      yjaco2=s23max-s23min

      s23=s23min+pyr(0)*yjaco2


C...CHECK THE SAMPLING

      IF(iknt.GT.100) THEN

        WRITE(mstu(11),*) ' IKNT > 100 IN PYTBDY '

        goto 120

      ENDIF

      IF(yjaco2.LT.pyr(0)*golden) goto 110

  120 d3=(xm(5)**2+xm(3)**2-s12)/(2d0*xm(5))

      d1=(xm(5)**2+xm(1)**2-s23)/(2d0*xm(5))

      d2=xm(5)-d1-d3

      p1=sqrt(d1*d1-xm(1)**2)

      p2=sqrt(d2*d2-xm(2)**2)

      p3=sqrt(d3*d3-xm(3)**2)

      cthe1=2d0*pyr(0)-1d0

      ang1=2d0*pyr(0)*paru(1)

      cphi1=cos(ang1)

      sphi1=sin(ang1)

      arg=1d0-cthe1**2

      IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0

      sthe1=sqrt(arg)

      p(n+1,1)=p1*sthe1*cphi1

      p(n+1,2)=p1*sthe1*sphi1

      p(n+1,3)=p1*cthe1

      p(n+1,4)=d1


C...GET CPHI3

      ang3=2d0*pyr(0)*paru(1)

      cphi3=cos(ang3)

      sphi3=sin(ang3)

      cthe3=(p2**2-p1**2-p3**2)/2d0/p1/p3

      arg=1d0-cthe3**2

      IF(arg.LT.0d0.AND.arg.GT.-1d-3) arg=0d0

      sthe3=sqrt(arg)

      p(n+3,1)=-p3*sthe3*cphi3*cthe1*cphi1

     &+p3*sthe3*sphi3*sphi1

     &+p3*cthe3*sthe1*cphi1

      p(n+3,2)=-p3*sthe3*cphi3*cthe1*sphi1

     &-p3*sthe3*sphi3*cphi1

     &+p3*cthe3*sthe1*sphi1

      p(n+3,3)=p3*sthe3*cphi3*sthe1

     &+p3*cthe3*cthe1

      p(n+3,4)=d3


      DO 130 i=1,3

        p(n+2,i)=-p(n+1,i)-p(n+3,i)

  130 CONTINUE

      p(n+2,4)=d2


      RETURN

      END


C*********************************************************************


C...PY1ENT

C...Stores one parton/particle in commonblock PYJETS.


      SUBROUTINE py1ent(IP,KF,PE,THE,PHI)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Standard checks.

      mstu(28)=0

      IF(mstu(12).GE.1) CALL pylist(0)

      ipa=max(1,iabs(ip))

      IF(ipa.GT.mstu(4)) CALL pyerrm(21,

     &'(PY1ENT:) writing outside PYJETS memory')

      kc=pycomp(kf)

      IF(kc.EQ.0) CALL pyerrm(12,'(PY1ENT:) unknown flavour code')


C...Find mass. Reset K, P and V vectors.

      pm=0d0

      IF(mstu(10).EQ.1) pm=p(ipa,5)

      IF(mstu(10).GE.2) pm=pymass(kf)

      DO 100 j=1,5

        k(ipa,j)=0

        p(ipa,j)=0d0

        v(ipa,j)=0d0

  100 CONTINUE


C...Store parton/particle in K and P vectors.

      k(ipa,1)=1

      IF(ip.LT.0) k(ipa,1)=2

      k(ipa,2)=kf

      p(ipa,5)=pm

      p(ipa,4)=max(pe,pm)

      pa=sqrt(p(ipa,4)**2-p(ipa,5)**2)

      p(ipa,1)=pa*sin(the)*cos(phi)

      p(ipa,2)=pa*sin(the)*sin(phi)

      p(ipa,3)=pa*cos(the)


C...Set N. Optionally fragment/decay.

      n=ipa

      IF(ip.EQ.0) CALL pyexec


      RETURN

      END


C*********************************************************************


C...PY2ENT

C...Stores two partons/particles in their CM frame,

C...with the first along the +z axis.


      SUBROUTINE py2ent(IP,KF1,KF2,PECM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Standard checks.

      mstu(28)=0

      IF(mstu(12).GE.1) CALL pylist(0)

      ipa=max(1,iabs(ip))

      IF(ipa.GT.mstu(4)-1) CALL pyerrm(21,

     &'(PY2ENT:) writing outside PYJETS memory')

      kc1=pycomp(kf1)

      kc2=pycomp(kf2)

      IF(kc1.EQ.0.OR.kc2.EQ.0) CALL pyerrm(12,

     &'(PY2ENT:) unknown flavour code')


C...Find masses. Reset K, P and V vectors.

      pm1=0d0

      IF(mstu(10).EQ.1) pm1=p(ipa,5)

      IF(mstu(10).GE.2) pm1=pymass(kf1)

      pm2=0d0

      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)

      IF(mstu(10).GE.2) pm2=pymass(kf2)

      DO 110 i=ipa,ipa+1

        DO 100 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  100   CONTINUE

  110 CONTINUE


C...Check flavours.

      kq1=kchg(kc1,2)*isign(1,kf1)

      kq2=kchg(kc2,2)*isign(1,kf2)

      IF(mstu(19).EQ.1) THEN

        mstu(19)=0

      ELSE

        IF(kq1+kq2.NE.0.AND.kq1+kq2.NE.4) CALL pyerrm(2,

     &  '(PY2ENT:) unphysical flavour combination')

      ENDIF

      k(ipa,2)=kf1

      k(ipa+1,2)=kf2


C...Store partons/particles in K vectors for normal case.

      IF(ip.GE.0) THEN

        k(ipa,1)=1

        IF(kq1.NE.0.AND.kq2.NE.0) k(ipa,1)=2

        k(ipa+1,1)=1


C...Store partons in K vectors for parton shower evolution.

      ELSE

        k(ipa,1)=3

        k(ipa+1,1)=3

        k(ipa,4)=mstu(5)*(ipa+1)

        k(ipa,5)=k(ipa,4)

        k(ipa+1,4)=mstu(5)*ipa

        k(ipa+1,5)=k(ipa+1,4)

      ENDIF


C...Check kinematics and store partons/particles in P vectors.

      IF(pecm.LE.pm1+pm2) CALL pyerrm(13,

     &'(PY2ENT:) energy smaller than sum of masses')

      pa=sqrt(max(0d0,(pecm**2-pm1**2-pm2**2)**2-(2d0*pm1*pm2)**2))/

     &(2d0*pecm)

      p(ipa,3)=pa

      p(ipa,4)=sqrt(pm1**2+pa**2)

      p(ipa,5)=pm1

      p(ipa+1,3)=-pa

      p(ipa+1,4)=sqrt(pm2**2+pa**2)

      p(ipa+1,5)=pm2


C...Set N. Optionally fragment/decay.

      n=ipa+1

      IF(ip.EQ.0) CALL pyexec


      RETURN

      END


C*********************************************************************


C...PY3ENT

C...Stores three partons or particles in their CM frame,

C...with the first along the +z axis and the third in the (x,z)

C...plane with x > 0.


      SUBROUTINE py3ent(IP,KF1,KF2,KF3,PECM,X1,X3)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Standard checks.

      mstu(28)=0

      IF(mstu(12).GE.1) CALL pylist(0)

      ipa=max(1,iabs(ip))

      IF(ipa.GT.mstu(4)-2) CALL pyerrm(21,

     &'(PY3ENT:) writing outside PYJETS memory')

      kc1=pycomp(kf1)

      kc2=pycomp(kf2)

      kc3=pycomp(kf3)

      IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0) CALL pyerrm(12,

     &'(PY3ENT:) unknown flavour code')


C...Find masses. Reset K, P and V vectors.

      pm1=0d0

      IF(mstu(10).EQ.1) pm1=p(ipa,5)

      IF(mstu(10).GE.2) pm1=pymass(kf1)

      pm2=0d0

      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)

      IF(mstu(10).GE.2) pm2=pymass(kf2)

      pm3=0d0

      IF(mstu(10).EQ.1) pm3=p(ipa+2,5)

      IF(mstu(10).GE.2) pm3=pymass(kf3)

      DO 110 i=ipa,ipa+2

        DO 100 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  100   CONTINUE

  110 CONTINUE


C...Check flavours.

      kq1=kchg(kc1,2)*isign(1,kf1)

      kq2=kchg(kc2,2)*isign(1,kf2)

      kq3=kchg(kc3,2)*isign(1,kf3)

      IF(mstu(19).EQ.1) THEN

        mstu(19)=0

      ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0) THEN

      ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.(kq1+kq3.EQ.0.OR.

     &  kq1+kq3.EQ.4)) THEN

      ELSE

        CALL pyerrm(2,'(PY3ENT:) unphysical flavour combination')

      ENDIF

      k(ipa,2)=kf1

      k(ipa+1,2)=kf2

      k(ipa+2,2)=kf3


C...Store partons/particles in K vectors for normal case.

      IF(ip.GE.0) THEN

        k(ipa,1)=1

        IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0)) k(ipa,1)=2

        k(ipa+1,1)=1

        IF(kq2.NE.0.AND.kq3.NE.0) k(ipa+1,1)=2

        k(ipa+2,1)=1


C...Store partons in K vectors for parton shower evolution.

      ELSE

        k(ipa,1)=3

        k(ipa+1,1)=3

        k(ipa+2,1)=3

        kcs=4

        IF(kq1.EQ.-1) kcs=5

        k(ipa,kcs)=mstu(5)*(ipa+1)

        k(ipa,9-kcs)=mstu(5)*(ipa+2)

        k(ipa+1,kcs)=mstu(5)*(ipa+2)

        k(ipa+1,9-kcs)=mstu(5)*ipa

        k(ipa+2,kcs)=mstu(5)*ipa

        k(ipa+2,9-kcs)=mstu(5)*(ipa+1)

      ENDIF


C...Check kinematics.

      mkerr=0

      IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*(2d0-x1-x3)*pecm.LE.pm2.OR.

     &0.5d0*x3*pecm.LE.pm3) mkerr=1

      pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))

      pa2=sqrt(max(1d-10,(0.5d0*(2d0-x1-x3)*pecm)**2-pm2**2))

      pa3=sqrt(max(1d-10,(0.5d0*x3*pecm)**2-pm3**2))

      cthe2=(pa3**2-pa1**2-pa2**2)/(2d0*pa1*pa2)

      cthe3=(pa2**2-pa1**2-pa3**2)/(2d0*pa1*pa3)

      IF(abs(cthe2).GE.1.001d0.OR.abs(cthe3).GE.1.001d0) mkerr=1

      cthe3=max(-1d0,min(1d0,cthe3))

      IF(mkerr.NE.0) CALL pyerrm(13,

     &'(PY3ENT:) unphysical kinematical variable setup')


C...Store partons/particles in P vectors.

      p(ipa,3)=pa1

      p(ipa,4)=sqrt(pa1**2+pm1**2)

      p(ipa,5)=pm1

      p(ipa+2,1)=pa3*sqrt(1d0-cthe3**2)

      p(ipa+2,3)=pa3*cthe3

      p(ipa+2,4)=sqrt(pa3**2+pm3**2)

      p(ipa+2,5)=pm3

      p(ipa+1,1)=-p(ipa+2,1)

      p(ipa+1,3)=-p(ipa,3)-p(ipa+2,3)

      p(ipa+1,4)=sqrt(p(ipa+1,1)**2+p(ipa+1,3)**2+pm2**2)

      p(ipa+1,5)=pm2


C...Set N. Optionally fragment/decay.

      n=ipa+2

      IF(ip.EQ.0) CALL pyexec


      RETURN

      END


C*********************************************************************


C...PY4ENT

C...Stores four partons or particles in their CM frame, with

C...the first along the +z axis, the last in the xz plane with x > 0

C...and the second having y < 0 and y > 0 with equal probability.


      SUBROUTINE py4ent(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Standard checks.

      mstu(28)=0

      IF(mstu(12).GE.1) CALL pylist(0)

      ipa=max(1,iabs(ip))

      IF(ipa.GT.mstu(4)-3) CALL pyerrm(21,

     &'(PY4ENT:) writing outside PYJETS momory')

      kc1=pycomp(kf1)

      kc2=pycomp(kf2)

      kc3=pycomp(kf3)

      kc4=pycomp(kf4)

      IF(kc1.EQ.0.OR.kc2.EQ.0.OR.kc3.EQ.0.OR.kc4.EQ.0) CALL pyerrm(12,

     &'(PY4ENT:) unknown flavour code')


C...Find masses. Reset K, P and V vectors.

      pm1=0d0

      IF(mstu(10).EQ.1) pm1=p(ipa,5)

      IF(mstu(10).GE.2) pm1=pymass(kf1)

      pm2=0d0

      IF(mstu(10).EQ.1) pm2=p(ipa+1,5)

      IF(mstu(10).GE.2) pm2=pymass(kf2)

      pm3=0d0

      IF(mstu(10).EQ.1) pm3=p(ipa+2,5)

      IF(mstu(10).GE.2) pm3=pymass(kf3)

      pm4=0d0

      IF(mstu(10).EQ.1) pm4=p(ipa+3,5)

      IF(mstu(10).GE.2) pm4=pymass(kf4)

      DO 110 i=ipa,ipa+3

        DO 100 j=1,5

          k(i,j)=0

          p(i,j)=0d0

          v(i,j)=0d0

  100   CONTINUE

  110 CONTINUE


C...Check flavours.

      kq1=kchg(kc1,2)*isign(1,kf1)

      kq2=kchg(kc2,2)*isign(1,kf2)

      kq3=kchg(kc3,2)*isign(1,kf3)

      kq4=kchg(kc4,2)*isign(1,kf4)

      IF(mstu(19).EQ.1) THEN

        mstu(19)=0

      ELSEIF(kq1.EQ.0.AND.kq2.EQ.0.AND.kq3.EQ.0.AND.kq4.EQ.0) THEN

      ELSEIF(kq1.NE.0.AND.kq2.EQ.2.AND.kq3.EQ.2.AND.(kq1+kq4.EQ.0.OR.

     &  kq1+kq4.EQ.4)) THEN

      ELSEIF(kq1.NE.0.AND.kq1+kq2.EQ.0.AND.kq3.NE.0.AND.kq3+kq4.EQ.0d0)

     &  THEN

      ELSE

        CALL pyerrm(2,'(PY4ENT:) unphysical flavour combination')

      ENDIF

      k(ipa,2)=kf1

      k(ipa+1,2)=kf2

      k(ipa+2,2)=kf3

      k(ipa+3,2)=kf4


C...Store partons/particles in K vectors for normal case.

      IF(ip.GE.0) THEN

        k(ipa,1)=1

        IF(kq1.NE.0.AND.(kq2.NE.0.OR.kq3.NE.0.OR.kq4.NE.0)) k(ipa,1)=2

        k(ipa+1,1)=1

        IF(kq2.NE.0.AND.kq1+kq2.NE.0.AND.(kq3.NE.0.OR.kq4.NE.0))

     &  k(ipa+1,1)=2

        k(ipa+2,1)=1

        IF(kq3.NE.0.AND.kq4.NE.0) k(ipa+2,1)=2

        k(ipa+3,1)=1


C...Store partons for parton shower evolution from q-g-g-qbar or

C...g-g-g-g event.

      ELSEIF(kq1+kq2.NE.0) THEN

        k(ipa,1)=3

        k(ipa+1,1)=3

        k(ipa+2,1)=3

        k(ipa+3,1)=3

        kcs=4

        IF(kq1.EQ.-1) kcs=5

        k(ipa,kcs)=mstu(5)*(ipa+1)

        k(ipa,9-kcs)=mstu(5)*(ipa+3)

        k(ipa+1,kcs)=mstu(5)*(ipa+2)

        k(ipa+1,9-kcs)=mstu(5)*ipa

        k(ipa+2,kcs)=mstu(5)*(ipa+3)

        k(ipa+2,9-kcs)=mstu(5)*(ipa+1)

        k(ipa+3,kcs)=mstu(5)*ipa

        k(ipa+3,9-kcs)=mstu(5)*(ipa+2)


C...Store partons for parton shower evolution from q-qbar-q-qbar event.

      ELSE

        k(ipa,1)=3

        k(ipa+1,1)=3

        k(ipa+2,1)=3

        k(ipa+3,1)=3

        k(ipa,4)=mstu(5)*(ipa+1)

        k(ipa,5)=k(ipa,4)

        k(ipa+1,4)=mstu(5)*ipa

        k(ipa+1,5)=k(ipa+1,4)

        k(ipa+2,4)=mstu(5)*(ipa+3)

        k(ipa+2,5)=k(ipa+2,4)

        k(ipa+3,4)=mstu(5)*(ipa+2)

        k(ipa+3,5)=k(ipa+3,4)

      ENDIF


C...Check kinematics.

      mkerr=0

      IF(0.5d0*x1*pecm.LE.pm1.OR.0.5d0*x2*pecm.LE.pm2.OR.

     &0.5d0*(2d0-x1-x2-x4)*pecm.LE.pm3.OR.0.5d0*x4*pecm.LE.pm4)

     &mkerr=1

      pa1=sqrt(max(1d-10,(0.5d0*x1*pecm)**2-pm1**2))

      pa2=sqrt(max(1d-10,(0.5d0*x2*pecm)**2-pm2**2))

      pa4=sqrt(max(1d-10,(0.5d0*x4*pecm)**2-pm4**2))

      x24=x1+x2+x4-1d0-x12-x14+(pm3**2-pm1**2-pm2**2-pm4**2)/pecm**2

      cthe4=(x1*x4-2d0*x14)*pecm**2/(4d0*pa1*pa4)

      IF(abs(cthe4).GE.1.002d0) mkerr=1

      cthe4=max(-1d0,min(1d0,cthe4))

      sthe4=sqrt(1d0-cthe4**2)

      cthe2=(x1*x2-2d0*x12)*pecm**2/(4d0*pa1*pa2)

      IF(abs(cthe2).GE.1.002d0) mkerr=1

      cthe2=max(-1d0,min(1d0,cthe2))

      sthe2=sqrt(1d0-cthe2**2)

      cphi2=((x2*x4-2d0*x24)*pecm**2-4d0*pa2*cthe2*pa4*cthe4)/

     &max(1d-8*pecm**2,4d0*pa2*sthe2*pa4*sthe4)

      IF(abs(cphi2).GE.1.05d0) mkerr=1

      cphi2=max(-1d0,min(1d0,cphi2))

      IF(mkerr.EQ.1) CALL pyerrm(13,

     &'(PY4ENT:) unphysical kinematical variable setup')


C...Store partons/particles in P vectors.

      p(ipa,3)=pa1

      p(ipa,4)=sqrt(pa1**2+pm1**2)

      p(ipa,5)=pm1

      p(ipa+3,1)=pa4*sthe4

      p(ipa+3,3)=pa4*cthe4

      p(ipa+3,4)=sqrt(pa4**2+pm4**2)

      p(ipa+3,5)=pm4

      p(ipa+1,1)=pa2*sthe2*cphi2

      p(ipa+1,2)=pa2*sthe2*sqrt(1d0-cphi2**2)*(-1d0)**int(pyr(0)+0.5d0)

      p(ipa+1,3)=pa2*cthe2

      p(ipa+1,4)=sqrt(pa2**2+pm2**2)

      p(ipa+1,5)=pm2

      p(ipa+2,1)=-p(ipa+1,1)-p(ipa+3,1)

      p(ipa+2,2)=-p(ipa+1,2)

      p(ipa+2,3)=-p(ipa,3)-p(ipa+1,3)-p(ipa+3,3)

      p(ipa+2,4)=sqrt(p(ipa+2,1)**2+p(ipa+2,2)**2+p(ipa+2,3)**2+pm3**2)

      p(ipa+2,5)=pm3


C...Set N. Optionally fragment/decay.

      n=ipa+3

      IF(ip.EQ.0) CALL pyexec


      RETURN

      END


C*********************************************************************


C...PYJOIN

C...Connects a sequence of partons with colour flow indices,

C...as required for subsequent shower evolution (or other operations).


      SUBROUTINE pyjoin(NJOIN,IJOIN)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local array.

      dimension ijoin(*)


C...Check that partons are of right types to be connected.

      IF(njoin.LT.2) goto 120

      kqsum=0

      DO 100 ijn=1,njoin

        i=ijoin(ijn)

        IF(i.LE.0.OR.i.GT.n) goto 120

        IF(k(i,1).LT.1.OR.k(i,1).GT.3) goto 120

        kc=pycomp(k(i,2))

        IF(kc.EQ.0) goto 120

        kq=kchg(kc,2)*isign(1,k(i,2))

        IF(kq.EQ.0) goto 120

        IF(ijn.NE.1.AND.ijn.NE.njoin.AND.kq.NE.2) goto 120

        IF(kq.NE.2) kqsum=kqsum+kq

        IF(ijn.EQ.1) kqs=kq

  100 CONTINUE

      IF(kqsum.NE.0) goto 120


C...Connect the partons sequentially (closing for gluon loop).

      kcs=(9-kqs)/2

      IF(kqs.EQ.2) kcs=int(4.5d0+pyr(0))

      DO 110 ijn=1,njoin

        i=ijoin(ijn)

        k(i,1)=3

        IF(ijn.NE.1) ip=ijoin(ijn-1)

        IF(ijn.EQ.1) ip=ijoin(njoin)

        IF(ijn.NE.njoin) in=ijoin(ijn+1)

        IF(ijn.EQ.njoin) in=ijoin(1)

        k(i,kcs)=mstu(5)*in

        k(i,9-kcs)=mstu(5)*ip

        IF(ijn.EQ.1.AND.kqs.NE.2) k(i,9-kcs)=0

        IF(ijn.EQ.njoin.AND.kqs.NE.2) k(i,kcs)=0

  110 CONTINUE


C...Error exit: no action taken.

      RETURN

  120 CALL pyerrm(12,

     &'(PYJOIN:) given entries can not be joined by one string')


      RETURN

      END


C*********************************************************************


C...PYGIVE

C...Sets values of commonblock variables.


      SUBROUTINE pygive(CHIN)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      common/pydatr/mrpy(6),rrpy(100)

      common/pysubs/msel,mselpd,msub(500),kfin(2,-40:40),ckin(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint3/xsfx(2,-40:40),isig(1000,3),sigh(1000)

      common/pyint4/mwid(500),wids(500,5)

      common/pyint5/ngenpd,ngen(0:500,3),xsec(0:500,3)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      common/pyint7/sigt(0:6,0:6,0:5)

      common/pyint8/xpvmd(-6:6),xpanl(-6:6),xpanh(-6:6),xpbeh(-6:6),

     &xpdir(-6:6)

      common/pymssm/imss(0:99),rmss(0:99)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pydat4/,/pydatr/,

     &/pysubs/,/pypars/,/pyint1/,/pyint2/,/pyint3/,/pyint4/,

     &/pyint5/,/pyint6/,/pyint7/,/pyint8/,/pymssm/

C...Local arrays and character variables.

      CHARACTER chin*(*),chfix*104,chbit*104,chold*8,chnew*8,chold2*28,

     &chnew2*28,chnam*6,chvar(49)*6,chalp(2)*26,chind*8,chini*10,

     &chinr*16

      dimension msvar(49,8)


C...For each variable to be translated give: name,

C...integer/real/character, no. of indices, lower&upper index bounds.

      DATA chvar/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',

     &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',

     &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',

     &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',

     &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',

     &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/

      DATA ((msvar(i,j),j=1,8),i=1,49)/ 1,7*0,  1,2,1,4000,1,5,2*0,

     &2,2,1,4000,1,5,2*0,  2,2,1,4000,1,5,2*0,  1,1,1,200,4*0,

     &2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,

     &1,2,1,500,1,4,2*0,  2,2,1,500,1,4,2*0,  2,1,1,2000,4*0,

     &2,2,1,4,1,4,2*0,  1,2,1,500,1,3,2*0,  1,2,1,4000,1,2,2*0,

     &2,1,1,4000,4*0,  1,2,1,4000,1,5,2*0,  3,2,1,500,1,2,2*0,

     &1,1,1,6,4*0,  2,1,1,100,4*0,

     &1,7*0,  1,1,1,500,4*0,  1,2,1,2,-40,40,2*0,  2,1,1,200,4*0,

     &1,1,1,200,4*0,  2,1,1,200,4*0,  1,1,1,200,4*0,  2,1,1,200,4*0,

     &1,1,1,400,4*0,  2,1,1,400,4*0,  1,1,1,500,4*0,

     &1,2,1,500,1,2,2*0,  2,2,1,500,1,20,2*0,  1,3,1,40,1,4,1,2,

     &2,2,1,2,-40,40,2*0,  1,2,1,1000,1,3,2*0,  2,1,1,1000,4*0,

     &1,1,1,500,4*0,   2,2,1,500,1,5,2*0,   1,2,0,500,1,3,2*0,

     &2,2,0,500,1,3,2*0,   4,1,0,500,4*0,   2,3,0,6,0,6,0,5,

     &2,1,-6,6,4*0,     2,1,-6,6,4*0,    2,1,-6,6,4*0,

     &2,1,-6,6,4*0,  2,1,-6,6,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0/

      DATA chalp/'abcdefghijklmnopqrstuvwxyz',

     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/


C...Length of character variable. Subdivide it into instructions.

      IF(mstu(12).GE.1) CALL pylist(0)

      chbit=chin//' '

      lbit=101

  100 lbit=lbit-1

      IF(chbit(lbit:lbit).EQ.' ') goto 100

      ltot=0

      DO 110 lcom=1,lbit

        IF(chbit(lcom:lcom).EQ.' ') goto 110

        ltot=ltot+1

        chfix(ltot:ltot)=chbit(lcom:lcom)

  110 CONTINUE

      llow=0

  120 lhig=llow+1

  130 lhig=lhig+1

      IF(lhig.LE.ltot.AND.chfix(lhig:lhig).NE.';') goto 130

      lbit=lhig-llow-1

      chbit(1:lbit)=chfix(llow+1:lhig-1)


C...Identify commonblock variable.

      lnam=1

  140 lnam=lnam+1

      IF(chbit(lnam:lnam).NE.'('.AND.chbit(lnam:lnam).NE.'='.AND.

     &lnam.LE.6) goto 140

      chnam=chbit(1:lnam-1)//' '

      DO 160 lcom=1,lnam-1

        DO 150 lalp=1,26

          IF(chnam(lcom:lcom).EQ.chalp(1)(lalp:lalp)) chnam(lcom:lcom)=

     &    chalp(2)(lalp:lalp)

  150   CONTINUE

  160 CONTINUE

      ivar=0

      DO 170 iv=1,49

        IF(chnam.EQ.chvar(iv)) ivar=iv

  170 CONTINUE

      IF(ivar.EQ.0) THEN

        CALL pyerrm(18,'(PYGIVE:) do not recognize variable '//chnam)

        llow=lhig

        IF(llow.LT.ltot) goto 120

        RETURN

      ENDIF


C...Identify any indices.

      i1=0

      i2=0

      i3=0

      nindx=0

      IF(chbit(lnam:lnam).EQ.'(') THEN

        lind=lnam

  180   lind=lind+1

        IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 180

        chind=' '

        IF((chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.'c')

     &  .AND.(ivar.EQ.9.OR.ivar.EQ.10.OR.ivar.EQ.13.OR.ivar.EQ.17))

     &  THEN

          chind(lnam-lind+11:8)=chbit(lnam+2:lind-1)

          READ(chind,'(I8)') kf

          i1=pycomp(kf)

        ELSEIF(chbit(lnam+1:lnam+1).EQ.'C'.OR.chbit(lnam+1:lnam+1).EQ.

     &    'c') THEN

          CALL pyerrm(18,'(PYGIVE:) not allowed to use C index for '//

     &    chnam)

          llow=lhig

          IF(llow.LT.ltot) goto 120

          RETURN

        ELSE

          chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)

          READ(chind,'(I8)') i1

        ENDIF

        lnam=lind

        IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1

        nindx=1

      ENDIF

      IF(chbit(lnam:lnam).EQ.',') THEN

        lind=lnam

  190   lind=lind+1

        IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 190

        chind=' '

        chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)

        READ(chind,'(I8)') i2

        lnam=lind

        IF(chbit(lnam:lnam).EQ.')') lnam=lnam+1

        nindx=2

      ENDIF

      IF(chbit(lnam:lnam).EQ.',') THEN

        lind=lnam

  200   lind=lind+1

        IF(chbit(lind:lind).NE.')'.AND.chbit(lind:lind).NE.',') goto 200

        chind=' '

        chind(lnam-lind+10:8)=chbit(lnam+1:lind-1)

        READ(chind,'(I8)') i3

        lnam=lind+1

        nindx=3

      ENDIF


C...Check that indices allowed.

      ierr=0

      IF(nindx.NE.msvar(ivar,2)) ierr=1

      IF(nindx.GE.1.AND.(i1.LT.msvar(ivar,3).OR.i1.GT.msvar(ivar,4)))

     &ierr=2

      IF(nindx.GE.2.AND.(i2.LT.msvar(ivar,5).OR.i2.GT.msvar(ivar,6)))

     &ierr=3

      IF(nindx.EQ.3.AND.(i3.LT.msvar(ivar,7).OR.i3.GT.msvar(ivar,8)))

     &ierr=4

      IF(chbit(lnam:lnam).NE.'=') ierr=5

      IF(ierr.GE.1) THEN

        CALL pyerrm(18,'(PYGIVE:) unallowed indices for '//

     &  chbit(1:lnam-1))

        llow=lhig

        IF(llow.LT.ltot) goto 120

        RETURN

      ENDIF


C...Save old value of variable.

      IF(ivar.EQ.1) THEN

        iold=n

      ELSEIF(ivar.EQ.2) THEN

        iold=k(i1,i2)

      ELSEIF(ivar.EQ.3) THEN

        rold=p(i1,i2)

      ELSEIF(ivar.EQ.4) THEN

        rold=v(i1,i2)

      ELSEIF(ivar.EQ.5) THEN

        iold=mstu(i1)

      ELSEIF(ivar.EQ.6) THEN

        rold=paru(i1)

      ELSEIF(ivar.EQ.7) THEN

        iold=mstj(i1)

      ELSEIF(ivar.EQ.8) THEN

        rold=parj(i1)

      ELSEIF(ivar.EQ.9) THEN

        iold=kchg(i1,i2)

      ELSEIF(ivar.EQ.10) THEN

        rold=pmas(i1,i2)

      ELSEIF(ivar.EQ.11) THEN

        rold=parf(i1)

      ELSEIF(ivar.EQ.12) THEN

        rold=vckm(i1,i2)

      ELSEIF(ivar.EQ.13) THEN

        iold=mdcy(i1,i2)

      ELSEIF(ivar.EQ.14) THEN

        iold=mdme(i1,i2)

      ELSEIF(ivar.EQ.15) THEN

        rold=brat(i1)

      ELSEIF(ivar.EQ.16) THEN

        iold=kfdp(i1,i2)

      ELSEIF(ivar.EQ.17) THEN

        chold=chaf(i1,i2)

      ELSEIF(ivar.EQ.18) THEN

        iold=mrpy(i1)

      ELSEIF(ivar.EQ.19) THEN

        rold=rrpy(i1)

      ELSEIF(ivar.EQ.20) THEN

        iold=msel

      ELSEIF(ivar.EQ.21) THEN

        iold=msub(i1)

      ELSEIF(ivar.EQ.22) THEN

        iold=kfin(i1,i2)

      ELSEIF(ivar.EQ.23) THEN

        rold=ckin(i1)

      ELSEIF(ivar.EQ.24) THEN

        iold=mstp(i1)

      ELSEIF(ivar.EQ.25) THEN

        rold=parp(i1)

      ELSEIF(ivar.EQ.26) THEN

        iold=msti(i1)

      ELSEIF(ivar.EQ.27) THEN

        rold=pari(i1)

      ELSEIF(ivar.EQ.28) THEN

        iold=mint(i1)

      ELSEIF(ivar.EQ.29) THEN

        rold=vint(i1)

      ELSEIF(ivar.EQ.30) THEN

        iold=iset(i1)

      ELSEIF(ivar.EQ.31) THEN

        iold=kfpr(i1,i2)

      ELSEIF(ivar.EQ.32) THEN

        rold=coef(i1,i2)

      ELSEIF(ivar.EQ.33) THEN

        iold=icol(i1,i2,i3)

      ELSEIF(ivar.EQ.34) THEN

        rold=xsfx(i1,i2)

      ELSEIF(ivar.EQ.35) THEN

        iold=isig(i1,i2)

      ELSEIF(ivar.EQ.36) THEN

        rold=sigh(i1)

      ELSEIF(ivar.EQ.37) THEN

        iold=mwid(i1)

      ELSEIF(ivar.EQ.38) THEN

        rold=wids(i1,i2)

      ELSEIF(ivar.EQ.39) THEN

        iold=ngen(i1,i2)

      ELSEIF(ivar.EQ.40) THEN

        rold=xsec(i1,i2)

      ELSEIF(ivar.EQ.41) THEN

        chold2=proc(i1)

      ELSEIF(ivar.EQ.42) THEN

        rold=sigt(i1,i2,i3)

      ELSEIF(ivar.EQ.43) THEN

        rold=xpvmd(i1)

      ELSEIF(ivar.EQ.44) THEN

        rold=xpanl(i1)

      ELSEIF(ivar.EQ.45) THEN

        rold=xpanh(i1)

      ELSEIF(ivar.EQ.46) THEN

        rold=xpbeh(i1)

      ELSEIF(ivar.EQ.47) THEN

        rold=xpdir(i1)

      ELSEIF(ivar.EQ.48) THEN

        iold=imss(i1)

      ELSEIF(ivar.EQ.49) THEN

        rold=rmss(i1)

      ENDIF


C...Print current value of variable. Loop back.

      IF(lnam.GE.lbit) THEN

        chbit(lnam:14)=' '

        chbit(15:60)=' has the value                                '

        IF(msvar(ivar,1).EQ.1) THEN

          WRITE(chbit(51:60),'(I10)') iold

        ELSEIF(msvar(ivar,1).EQ.2) THEN

          WRITE(chbit(47:60),'(F14.5)') rold

        ELSEIF(msvar(ivar,1).EQ.3) THEN

          chbit(53:60)=chold

        ELSE

          chbit(33:60)=chold

        ENDIF

        IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)

        llow=lhig

        IF(llow.LT.ltot) goto 120

        RETURN

      ENDIF


C...Read in new variable value.

      IF(msvar(ivar,1).EQ.1) THEN

        chini=' '

        chini(lnam-lbit+11:10)=chbit(lnam+1:lbit)

        READ(chini,'(I10)') inew

      ELSEIF(msvar(ivar,1).EQ.2) THEN

        chinr=' '

        chinr(lnam-lbit+17:16)=chbit(lnam+1:lbit)

        READ(chinr,*) rnew

      ELSEIF(msvar(ivar,1).EQ.3) THEN

        chnew=chbit(lnam+1:lbit)//' '

      ELSE

        chnew2=chbit(lnam+1:lbit)//' '

      ENDIF


C...Store new variable value.

      IF(ivar.EQ.1) THEN

        n=inew

      ELSEIF(ivar.EQ.2) THEN

        k(i1,i2)=inew

      ELSEIF(ivar.EQ.3) THEN

        p(i1,i2)=rnew

      ELSEIF(ivar.EQ.4) THEN

        v(i1,i2)=rnew

      ELSEIF(ivar.EQ.5) THEN

        mstu(i1)=inew

      ELSEIF(ivar.EQ.6) THEN

        paru(i1)=rnew

      ELSEIF(ivar.EQ.7) THEN

        mstj(i1)=inew

      ELSEIF(ivar.EQ.8) THEN

        parj(i1)=rnew

      ELSEIF(ivar.EQ.9) THEN

        kchg(i1,i2)=inew

      ELSEIF(ivar.EQ.10) THEN

        pmas(i1,i2)=rnew

      ELSEIF(ivar.EQ.11) THEN

        parf(i1)=rnew

      ELSEIF(ivar.EQ.12) THEN

        vckm(i1,i2)=rnew

      ELSEIF(ivar.EQ.13) THEN

        mdcy(i1,i2)=inew

      ELSEIF(ivar.EQ.14) THEN

        mdme(i1,i2)=inew

      ELSEIF(ivar.EQ.15) THEN

        brat(i1)=rnew

      ELSEIF(ivar.EQ.16) THEN

        kfdp(i1,i2)=inew

      ELSEIF(ivar.EQ.17) THEN

        chaf(i1,i2)=chnew

      ELSEIF(ivar.EQ.18) THEN

        mrpy(i1)=inew

      ELSEIF(ivar.EQ.19) THEN

        rrpy(i1)=rnew

      ELSEIF(ivar.EQ.20) THEN

        msel=inew

      ELSEIF(ivar.EQ.21) THEN

        msub(i1)=inew

      ELSEIF(ivar.EQ.22) THEN

        kfin(i1,i2)=inew

      ELSEIF(ivar.EQ.23) THEN

        ckin(i1)=rnew

      ELSEIF(ivar.EQ.24) THEN

        mstp(i1)=inew

      ELSEIF(ivar.EQ.25) THEN

        parp(i1)=rnew

      ELSEIF(ivar.EQ.26) THEN

        msti(i1)=inew

      ELSEIF(ivar.EQ.27) THEN

        pari(i1)=rnew

      ELSEIF(ivar.EQ.28) THEN

        mint(i1)=inew

      ELSEIF(ivar.EQ.29) THEN

        vint(i1)=rnew

      ELSEIF(ivar.EQ.30) THEN

        iset(i1)=inew

      ELSEIF(ivar.EQ.31) THEN

        kfpr(i1,i2)=inew

      ELSEIF(ivar.EQ.32) THEN

        coef(i1,i2)=rnew

      ELSEIF(ivar.EQ.33) THEN

        icol(i1,i2,i3)=inew

      ELSEIF(ivar.EQ.34) THEN

        xsfx(i1,i2)=rnew

      ELSEIF(ivar.EQ.35) THEN

        isig(i1,i2)=inew

      ELSEIF(ivar.EQ.36) THEN

        sigh(i1)=rnew

      ELSEIF(ivar.EQ.37) THEN

        mwid(i1)=inew

      ELSEIF(ivar.EQ.38) THEN

        wids(i1,i2)=rnew

      ELSEIF(ivar.EQ.39) THEN

        ngen(i1,i2)=inew

      ELSEIF(ivar.EQ.40) THEN

        xsec(i1,i2)=rnew

      ELSEIF(ivar.EQ.41) THEN

        proc(i1)=chnew2

      ELSEIF(ivar.EQ.42) THEN

        sigt(i1,i2,i3)=rnew

      ELSEIF(ivar.EQ.43) THEN

        xpvmd(i1)=rnew

      ELSEIF(ivar.EQ.44) THEN

        xpanl(i1)=rnew

      ELSEIF(ivar.EQ.45) THEN

        xpanh(i1)=rnew

      ELSEIF(ivar.EQ.46) THEN

        xpbeh(i1)=rnew

      ELSEIF(ivar.EQ.47) THEN

        xpdir(i1)=rnew

      ELSEIF(ivar.EQ.48) THEN

        imss(i1)=inew

      ELSEIF(ivar.EQ.49) THEN

        rmss(i1)=rnew

      ENDIF


C...Write old and new value. Loop back.

      chbit(lnam:14)=' '

      chbit(15:60)=' changed from                to               '

      IF(msvar(ivar,1).EQ.1) THEN

        WRITE(chbit(33:42),'(I10)') iold

        WRITE(chbit(51:60),'(I10)') inew

        IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)

      ELSEIF(msvar(ivar,1).EQ.2) THEN

        WRITE(chbit(29:42),'(F14.5)') rold

        WRITE(chbit(47:60),'(F14.5)') rnew

        IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)

      ELSEIF(msvar(ivar,1).EQ.3) THEN

        chbit(35:42)=chold

        chbit(53:60)=chnew

        IF(mstu(13).GE.1) WRITE(mstu(11),5000) chbit(1:60)

      ELSE

        chbit(15:88)=' changed from '//chold2//' to '//chnew2

        IF(mstu(13).GE.1) WRITE(mstu(11),5100) chbit(1:88)

      ENDIF

      llow=lhig

      IF(llow.LT.ltot) goto 120


C...Format statement for output on unit MSTU(11) (by default 6).

 5000 FORMAT(5x,a60)

 5100 FORMAT(5x,a88)


      RETURN

      END


C*********************************************************************


C...PYEXEC

C...Administrates the fragmentation and decay chain.


      SUBROUTINE pyexec


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pyint4/mwid(500),wids(500,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/,/pyint4/

C...Local array.

      dimension ps(2,6),ijoin(100)


C...Initialize and reset.

      mstu(24)=0

      IF(mstu(12).GE.1) CALL pylist(0)

      mstu(31)=mstu(31)+1

      mstu(1)=0

      mstu(2)=0

      mstu(3)=0

      IF(mstu(17).LE.0) mstu(90)=0

      mcons=1


C...Sum up momentum, energy and charge for starting entries.

      nsav=n

      DO 110 i=1,2

        DO 100 j=1,6

          ps(i,j)=0d0

  100   CONTINUE

  110 CONTINUE

      DO 130 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 130

        DO 120 j=1,4

          ps(1,j)=ps(1,j)+p(i,j)

  120   CONTINUE

        ps(1,6)=ps(1,6)+pychge(k(i,2))

  130 CONTINUE

      paru(21)=ps(1,4)


C...Prepare system for subsequent fragmentation/decay.

      CALL pyprep(0)


C...Loop through jet fragmentation and particle decays.

      mbe=0

  140 mbe=mbe+1

      ip=0

  150 ip=ip+1

      kc=0

      IF(k(ip,1).GT.0.AND.k(ip,1).LE.10) kc=pycomp(k(ip,2))

      IF(kc.EQ.0) THEN


C...Deal with any remaining undecayed resonance

C...(normally the task of PYEVNT, so seldom used).

      ELSEIF(mwid(kc).NE.0) THEN

        ibeg=ip

        IF(kchg(kc,2).NE.0.AND.k(i,1).NE.3) THEN

          ibeg=ip+1

  160     ibeg=ibeg-1

          IF(ibeg.GE.2.AND.k(ibeg,1).EQ.2) goto 160

          IF(k(ibeg,1).NE.2) ibeg=ibeg+1

          iend=ip-1

  170     iend=iend+1

          IF(iend.LT.n.AND.k(iend,1).EQ.2) goto 170

          IF(iend.LT.n.AND.kchg(pycomp(k(iend,2)),2).EQ.0) goto 170

          njoin=0

          DO 180 i=ibeg,iend

            IF(kchg(pycomp(k(iend,2)),2).NE.0) THEN

              njoin=njoin+1

              ijoin(njoin)=i

            ENDIF

  180     CONTINUE

        ENDIF

        CALL pyresd(ip)

        CALL pyprep(ibeg)


C...Particle decay if unstable and allowed. Save long-lived particle

C...decays until second pass after Bose-Einstein effects.

      ELSEIF(kchg(kc,2).EQ.0) THEN

        IF(mstj(21).GE.1.AND.mdcy(kc,1).GE.1.AND.(mstj(51).LE.0.OR.mbe

     &  .EQ.2.OR.pmas(kc,2).GE.parj(91).OR.iabs(k(ip,2)).EQ.311))

     &  CALL pydecy(ip)


C...Decay products may develop a shower.

        IF(mstj(92).GT.0) THEN

          ip1=mstj(92)

          qmax=sqrt(max(0d0,(p(ip1,4)+p(ip1+1,4))**2-(p(ip1,1)+p(ip1+1,

     &    1))**2-(p(ip1,2)+p(ip1+1,2))**2-(p(ip1,3)+p(ip1+1,3))**2))

          CALL pyshow(ip1,ip1+1,qmax)

          CALL pyprep(ip1)

          mstj(92)=0

        ELSEIF(mstj(92).LT.0) THEN

          ip1=-mstj(92)

          CALL pyshow(ip1,-3,p(ip,5))

          CALL pyprep(ip1)

          mstj(92)=0

        ENDIF


C...Jet fragmentation: string or independent fragmentation.

      ELSEIF(k(ip,1).EQ.1.OR.k(ip,1).EQ.2) THEN

        mfrag=mstj(1)

        IF(mfrag.GE.1.AND.k(ip,1).EQ.1) mfrag=2

        IF(mstj(21).GE.2.AND.k(ip,1).EQ.2.AND.n.GT.ip) THEN

          IF(k(ip+1,1).EQ.1.AND.k(ip+1,3).EQ.k(ip,3).AND.

     &    k(ip,3).GT.0.AND.k(ip,3).LT.ip) THEN

            IF(kchg(pycomp(k(k(ip,3),2)),2).EQ.0) mfrag=min(1,mfrag)

          ENDIF

        ENDIF

        IF(mfrag.EQ.1) CALL pystrf(ip)

        IF(mfrag.EQ.2) CALL pyindf(ip)

        IF(mfrag.EQ.2.AND.k(ip,1).EQ.1) mcons=0

        IF(mfrag.EQ.2.AND.(mstj(3).LE.0.OR.mod(mstj(3),5).EQ.0)) mcons=0

      ENDIF


C...Loop back if enough space left in PYJETS and no error abort.

      IF(mstu(24).NE.0.AND.mstu(21).GE.2) THEN

      ELSEIF(ip.LT.n.AND.n.LT.mstu(4)-20-mstu(32)) THEN

        goto 150

      ELSEIF(ip.LT.n) THEN

        CALL pyerrm(11,'(PYEXEC:) no more memory left in PYJETS')

      ENDIF


C...Include simple Bose-Einstein effect parametrization if desired.

      IF(mbe.EQ.1.AND.mstj(51).GE.1) THEN

        CALL pyboei(nsav)

        goto 140

      ENDIF


C...Check that momentum, energy and charge were conserved.

      DO 200 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 200

        DO 190 j=1,4

          ps(2,j)=ps(2,j)+p(i,j)

  190   CONTINUE

        ps(2,6)=ps(2,6)+pychge(k(i,2))

  200 CONTINUE

      pdev=(abs(ps(2,1)-ps(1,1))+abs(ps(2,2)-ps(1,2))+abs(ps(2,3)-

     &ps(1,3))+abs(ps(2,4)-ps(1,4)))/(1d0+abs(ps(2,4))+abs(ps(1,4)))

      IF(mcons.EQ.1.AND.pdev.GT.paru(11)) CALL pyerrm(15,

     &'(PYEXEC:) four-momentum was not conserved')

      IF(mcons.EQ.1.AND.abs(ps(2,6)-ps(1,6)).GT.0.1d0) CALL pyerrm(15,

     &'(PYEXEC:) charge was not conserved')


      RETURN

      END


C*********************************************************************


C...PYPREP

C...Rearranges partons along strings. Allows small systems

C...to collapse into one or two particles and checks flavours.


      SUBROUTINE pyprep(IP)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/

C...Local arrays.

      dimension dps(5),dpc(5),ue(3)


C...Rearrange parton shower product listing along strings: begin loop.

      i1=n

      DO 130 mqgst=1,2

        DO 120 i=max(1,ip),n

          IF(k(i,1).NE.3) goto 120

          kc=pycomp(k(i,2))

          IF(kc.EQ.0) goto 120

          kq=kchg(kc,2)

          IF(kq.EQ.0.OR.(mqgst.EQ.1.AND.kq.EQ.2)) goto 120


C...Pick up loose string end.

          kcs=4

          IF(kq*isign(1,k(i,2)).LT.0) kcs=5

          ia=i

          nstp=0

  100     nstp=nstp+1

          IF(nstp.GT.4*n) THEN

            CALL pyerrm(14,'(PYPREP:) caught in infinite loop')

            RETURN

          ENDIF


C...Copy undecayed parton.

          IF(k(ia,1).EQ.3) THEN

            IF(i1.GE.mstu(4)-mstu(32)-5) THEN

              CALL pyerrm(11,'(PYPREP:) no more memory left in PYJETS')

              RETURN

            ENDIF

            i1=i1+1

            k(i1,1)=2

            IF(nstp.GE.2.AND.kchg(pycomp(k(ia,2)),2).NE.2) k(i1,1)=1

            k(i1,2)=k(ia,2)

            k(i1,3)=ia

            k(i1,4)=0

            k(i1,5)=0

            DO 110 j=1,5

              p(i1,j)=p(ia,j)

              v(i1,j)=v(ia,j)

  110       CONTINUE

            k(ia,1)=k(ia,1)+10

            IF(k(i1,1).EQ.1) goto 120

          ENDIF


C...Go to next parton in colour space.

          ib=ia

          IF(mod(k(ib,kcs)/mstu(5)**2,2).EQ.0.AND.mod(k(ib,kcs),mstu(5))

     &    .NE.0) THEN

            ia=mod(k(ib,kcs),mstu(5))

            k(ib,kcs)=k(ib,kcs)+mstu(5)**2

            mrev=0

          ELSE

            IF(k(ib,kcs).GE.2*mstu(5)**2.OR.mod(k(ib,kcs)/mstu(5),

     &      mstu(5)).EQ.0) kcs=9-kcs

            ia=mod(k(ib,kcs)/mstu(5),mstu(5))

            k(ib,kcs)=k(ib,kcs)+2*mstu(5)**2

            mrev=1

          ENDIF

          IF(ia.LE.0.OR.ia.GT.n) THEN

            CALL pyerrm(12,'(PYPREP:) colour rearrangement failed')

            RETURN

          ENDIF

          IF(mod(k(ia,4)/mstu(5),mstu(5)).EQ.ib.OR.mod(k(ia,5)/mstu(5),

     &    mstu(5)).EQ.ib) THEN

            IF(mrev.EQ.1) kcs=9-kcs

            IF(mod(k(ia,kcs)/mstu(5),mstu(5)).NE.ib) kcs=9-kcs

            k(ia,kcs)=k(ia,kcs)+2*mstu(5)**2

          ELSE

            IF(mrev.EQ.0) kcs=9-kcs

            IF(mod(k(ia,kcs),mstu(5)).NE.ib) kcs=9-kcs

            k(ia,kcs)=k(ia,kcs)+mstu(5)**2

          ENDIF

          IF(ia.NE.i) goto 100

          k(i1,1)=1

  120   CONTINUE

  130 CONTINUE

      n=i1

      IF(mstj(14).LT.0) RETURN


C...Find lowest-mass colour singlet jet system, OK if above threshold.

      IF(mstj(14).EQ.0) goto 320

      ns=n

  140 nsin=n-ns

      pdm=1d0+parj(32)

      ic=0

      DO 190 i=max(1,ip),ns

        IF(k(i,1).NE.1.AND.k(i,1).NE.2) THEN

        ELSEIF(k(i,1).EQ.2.AND.ic.EQ.0) THEN

          nsin=nsin+1

          ic=i

          DO 150 j=1,4

            dps(j)=p(i,j)

  150     CONTINUE

          mstj(93)=1

          dps(5)=pymass(k(i,2))

        ELSEIF(k(i,1).EQ.2) THEN

          DO 160 j=1,4

            dps(j)=dps(j)+p(i,j)

  160     CONTINUE

        ELSEIF(ic.NE.0.AND.kchg(pycomp(k(i,2)),2).NE.0) THEN

          DO 170 j=1,4

            dps(j)=dps(j)+p(i,j)

  170     CONTINUE

          mstj(93)=1

          dps(5)=dps(5)+pymass(k(i,2))

          pd=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))-

     &    dps(5)

          IF(pd.LT.pdm) THEN

            pdm=pd

            DO 180 j=1,5

              dpc(j)=dps(j)

  180       CONTINUE

            ic1=ic

            ic2=i

          ENDIF

          ic=0

        ELSE

          nsin=nsin+1

        ENDIF

  190 CONTINUE

      IF(pdm.GE.parj(32)) goto 320


C...Fill small-mass system as cluster.

      nsav=n

      pecm=sqrt(max(0d0,dpc(4)**2-dpc(1)**2-dpc(2)**2-dpc(3)**2))

      k(n+1,1)=11

      k(n+1,2)=91

      k(n+1,3)=ic1

      k(n+1,4)=n+2

      k(n+1,5)=n+3

      p(n+1,1)=dpc(1)

      p(n+1,2)=dpc(2)

      p(n+1,3)=dpc(3)

      p(n+1,4)=dpc(4)

      p(n+1,5)=pecm


C...Form two particles from flavours of lowest-mass system, if feasible.

      k(n+2,1)=1

      k(n+3,1)=1

      IF(mstu(16).NE.2) THEN

        k(n+2,3)=n+1

        k(n+3,3)=n+1

      ELSE

        k(n+2,3)=ic1

        k(n+3,3)=ic2

      ENDIF

      k(n+2,4)=0

      k(n+3,4)=0

      k(n+2,5)=0

      k(n+3,5)=0

      IF(iabs(k(ic1,2)).NE.21) THEN

        kc1=pycomp(k(ic1,2))

        kc2=pycomp(k(ic2,2))

        IF(kc1.EQ.0.OR.kc2.EQ.0) goto 320

        kq1=kchg(kc1,2)*isign(1,k(ic1,2))

        kq2=kchg(kc2,2)*isign(1,k(ic2,2))

        IF(kq1+kq2.NE.0) goto 320

  200   CALL pykfdi(k(ic1,2),0,kfln,k(n+2,2))

        CALL pykfdi(k(ic2,2),-kfln,kfldmp,k(n+3,2))

        IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 200

      ELSE

        IF(iabs(k(ic2,2)).NE.21) goto 320

  210   CALL pykfdi(1+int((2d0+parj(2))*pyr(0)),0,kfln,kfdmp)

        CALL pykfdi(kfln,0,kflm,k(n+2,2))

        CALL pykfdi(-kfln,-kflm,kfldmp,k(n+3,2))

        IF(k(n+2,2).EQ.0.OR.k(n+3,2).EQ.0) goto 210

      ENDIF

      p(n+2,5)=pymass(k(n+2,2))

      p(n+3,5)=pymass(k(n+3,2))

      IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm.AND.nsin.EQ.1) goto 320

      IF(p(n+2,5)+p(n+3,5)+parj(64).GE.pecm) goto 260


C...Perform two-particle decay of jet system, if possible.

      IF(pecm.GE.0.02d0*dpc(4)) THEN

        pa=sqrt((pecm**2-(p(n+2,5)+p(n+3,5))**2)*(pecm**2-

     &  (p(n+2,5)-p(n+3,5))**2))/(2d0*pecm)

        ue(3)=2d0*pyr(0)-1d0

        phi=paru(2)*pyr(0)

        ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)

        ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)

        DO 220 j=1,3

          p(n+2,j)=pa*ue(j)

          p(n+3,j)=-pa*ue(j)

  220   CONTINUE

        p(n+2,4)=sqrt(pa**2+p(n+2,5)**2)

        p(n+3,4)=sqrt(pa**2+p(n+3,5)**2)

        mstu(33)=1

        CALL pyrobo(n+2,n+3,0d0,0d0,dpc(1)/dpc(4),dpc(2)/dpc(4),

     &  dpc(3)/dpc(4))

      ELSE

        np=0

        DO 230 i=ic1,ic2

          IF(k(i,1).EQ.1.OR.k(i,1).EQ.2) np=np+1

  230   CONTINUE

        ha=p(ic1,4)*p(ic2,4)-p(ic1,1)*p(ic2,1)-p(ic1,2)*p(ic2,2)-

     &  p(ic1,3)*p(ic2,3)

        IF(np.GE.3.OR.ha.LE.1.25d0*p(ic1,5)*p(ic2,5)) goto 260

        hd1=0.5d0*(p(n+2,5)**2-p(ic1,5)**2)

        hd2=0.5d0*(p(n+3,5)**2-p(ic2,5)**2)

        hr=sqrt(max(0d0,((ha-hd1-hd2)**2-(p(n+2,5)*p(n+3,5))**2)/

     &  (ha**2-(p(ic1,5)*p(ic2,5))**2)))-1d0

        hc=p(ic1,5)**2+2d0*ha+p(ic2,5)**2

        hk1=((p(ic2,5)**2+ha)*hr+hd1-hd2)/hc

        hk2=((p(ic1,5)**2+ha)*hr+hd2-hd1)/hc

        DO 240 j=1,4

          p(n+2,j)=(1d0+hk1)*p(ic1,j)-hk2*p(ic2,j)

          p(n+3,j)=(1d0+hk2)*p(ic2,j)-hk1*p(ic1,j)

  240   CONTINUE

      ENDIF

      DO 250 j=1,4

        v(n+1,j)=v(ic1,j)

        v(n+2,j)=v(ic1,j)

        v(n+3,j)=v(ic2,j)

  250 CONTINUE

      v(n+1,5)=0d0

      v(n+2,5)=0d0

      v(n+3,5)=0d0

      n=n+3

      goto 300


C...Else form one particle from the flavours available, if possible.

  260 k(n+1,5)=n+2

      IF(iabs(k(ic1,2)).GT.100.AND.iabs(k(ic2,2)).GT.100) THEN

        goto 320

      ELSEIF(iabs(k(ic1,2)).NE.21) THEN

        CALL pykfdi(k(ic1,2),k(ic2,2),kfldmp,k(n+2,2))

      ELSE

        kfln=1+int((2d0+parj(2))*pyr(0))

        CALL pykfdi(kfln,-kfln,kfldmp,k(n+2,2))

      ENDIF

      IF(k(n+2,2).EQ.0) goto 260

      p(n+2,5)=pymass(k(n+2,2))


C...Find parton/particle which combines to largest extra mass.

      ir=0

      ha=0d0

      hsm=0d0

      DO 280 mcomb=1,3

        IF(ir.NE.0) goto 280

        DO 270 i=max(1,ip),n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10.OR.(i.GE.ic1.AND.i.LE.ic2

     &    .AND.k(i,1).GE.1.AND.k(i,1).LE.2)) goto 270

          IF(mcomb.EQ.1) kci=pycomp(k(i,2))

          IF(mcomb.EQ.1.AND.kci.EQ.0) goto 270

          IF(mcomb.EQ.1.AND.kchg(kci,2).EQ.0.AND.i.LE.ns) goto 270

          IF(mcomb.EQ.2.AND.iabs(k(i,2)).GT.10.AND.iabs(k(i,2)).LE.100)

     &    goto 270

          hcr=dpc(4)*p(i,4)-dpc(1)*p(i,1)-dpc(2)*p(i,2)-dpc(3)*p(i,3)

          hsr=2d0*hcr+pecm**2-p(n+2,5)**2-2d0*p(n+2,5)*p(i,5)

          IF(hsr.GT.hsm) THEN

            ir=i

            ha=hcr

            hsm=hsr

          ENDIF

  270   CONTINUE

  280 CONTINUE


C...Shuffle energy and momentum to put new particle on mass shell.

      IF(ir.NE.0) THEN

        hb=pecm**2+ha

        hc=p(n+2,5)**2+ha

        hd=p(ir,5)**2+ha

        hk2=0.5d0*(hb*sqrt(max(0d0,((hb+hc)**2-4d0*(hb+hd)*p(n+2,5)**2)/

     &  (ha**2-(pecm*p(ir,5))**2)))-(hb+hc))/(hb+hd)

        hk1=(0.5d0*(p(n+2,5)**2-pecm**2)+hd*hk2)/hb

        DO 290 j=1,4

          p(n+2,j)=(1d0+hk1)*dpc(j)-hk2*p(ir,j)

          p(ir,j)=(1d0+hk2)*p(ir,j)-hk1*dpc(j)

          v(n+1,j)=v(ic1,j)

          v(n+2,j)=v(ic1,j)

  290   CONTINUE

        v(n+1,5)=0d0

        v(n+2,5)=0d0

        n=n+2

      ELSE

        CALL pyerrm(3,'(PYPREP:) no match for collapsing cluster')

        RETURN

      ENDIF


C...Mark collapsed system and store daughter pointers. Iterate.

  300 DO 310 i=ic1,ic2

        IF((k(i,1).EQ.1.OR.k(i,1).EQ.2).AND.kchg(pycomp(k(i,2)),2).NE.0)

     &  THEN

          k(i,1)=k(i,1)+10

          IF(mstu(16).NE.2) THEN

            k(i,4)=nsav+1

            k(i,5)=nsav+1

          ELSE

            k(i,4)=nsav+2

            k(i,5)=n

          ENDIF

        ENDIF

  310 CONTINUE

      IF(n.LT.mstu(4)-mstu(32)-5) goto 140


C...Check flavours and invariant masses in parton systems.

  320 np=0

      kfn=0

      kqs=0

      DO 330 j=1,5

        dps(j)=0d0

  330 CONTINUE

      DO 360 i=max(1,ip),n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 360

        kc=pycomp(k(i,2))

        IF(kc.EQ.0) goto 360

        kq=kchg(kc,2)*isign(1,k(i,2))

        IF(kq.EQ.0) goto 360

        np=np+1

        IF(kq.NE.2) THEN

          kfn=kfn+1

          kqs=kqs+kq

          mstj(93)=1

          dps(5)=dps(5)+pymass(k(i,2))

        ENDIF

        DO 340 j=1,4

          dps(j)=dps(j)+p(i,j)

  340   CONTINUE

        IF(k(i,1).EQ.1) THEN

          IF(np.NE.1.AND.(kfn.EQ.1.OR.kfn.GE.3.OR.kqs.NE.0)) CALL

     &    pyerrm(2,'(PYPREP:) unphysical flavour combination')

          IF(np.NE.1.AND.dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2.LT.

     &    (0.9d0*parj(32)+dps(5))**2) CALL pyerrm(3,

     &    '(PYPREP:) too small mass in jet system')

          np=0

          kfn=0

          kqs=0

          DO 350 j=1,5

            dps(j)=0d0

  350     CONTINUE

        ENDIF

  360 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYSTRF

C...Handles the fragmentation of an arbitrary colour singlet

C...jet system according to the Lund string fragmentation model.


      SUBROUTINE pystrf(IP)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension dps(5),kfl(3),pmq(3),px(3),py(3),gam(3),ie(2),pr(2),

     &in(9),dhm(4),dhg(4),dp(5,5),irank(2),mju(4),iju(3),pju(5,5),

     &tju(5),kfjh(2),njs(2),kfjs(2),pjs(4,5),mstu9t(8),paru9t(8)


C...Function: four-product of two vectors.

      four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)

      dfour(i,j)=dp(i,4)*dp(j,4)-dp(i,1)*dp(j,1)-dp(i,2)*dp(j,2)-

     &dp(i,3)*dp(j,3)


C...Reset counters. Identify parton system.

      mstj(91)=0

      nsav=n

      mstu90=mstu(90)

      np=0

      kqsum=0

      DO 100 j=1,5

        dps(j)=0d0

  100 CONTINUE

      mju(1)=0

      mju(2)=0

      i=ip-1

  110 i=i+1

      IF(i.GT.min(n,mstu(4)-mstu(32))) THEN

        CALL pyerrm(12,'(PYSTRF:) failed to reconstruct jet system')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(k(i,1).NE.1.AND.k(i,1).NE.2.AND.k(i,1).NE.41) goto 110

      kc=pycomp(k(i,2))

      IF(kc.EQ.0) goto 110

      kq=kchg(kc,2)*isign(1,k(i,2))

      IF(kq.EQ.0) goto 110

      IF(n+5*np+11.GT.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Take copy of partons to be considered. Check flavour sum.

      np=np+1

      DO 120 j=1,5

        k(n+np,j)=k(i,j)

        p(n+np,j)=p(i,j)

        IF(j.NE.4) dps(j)=dps(j)+p(i,j)

  120 CONTINUE

      dps(4)=dps(4)+sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)

      k(n+np,3)=i

      IF(kq.NE.2) kqsum=kqsum+kq

      IF(k(i,1).EQ.41) THEN

        kqsum=kqsum+2*kq

        IF(kqsum.EQ.kq) mju(1)=n+np

        IF(kqsum.NE.kq) mju(2)=n+np

      ENDIF

      IF(k(i,1).EQ.2.OR.k(i,1).EQ.41) goto 110

      IF(kqsum.NE.0) THEN

        CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Boost copied system to CM frame (for better numerical precision).

      IF(abs(dps(3)).LT.0.99d0*dps(4)) THEN

        mbst=0

        mstu(33)=1

        CALL pyrobo(n+1,n+np,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),

     &  -dps(3)/dps(4))

      ELSE

        mbst=1

        hhbz=sqrt(max(1d-6,dps(4)+dps(3))/max(1d-6,dps(4)-dps(3)))

        DO 130 i=n+1,n+np

          hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2

          IF(p(i,3).GT.0d0) THEN

            hhpez=(p(i,4)+p(i,3))/hhbz

            p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)

            p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)

          ELSE

            hhpez=(p(i,4)-p(i,3))*hhbz

            p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)

            p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)

          ENDIF

  130   CONTINUE

      ENDIF


C...Search for very nearby partons that may be recombined.

      ntryr=0

      paru12=paru(12)

      paru13=paru(13)

      mju(3)=mju(1)

      mju(4)=mju(2)

      nr=np

  140 IF(nr.GE.3) THEN

        pdrmin=2d0*paru12

        DO 150 i=n+1,n+nr

          IF(i.EQ.n+nr.AND.iabs(k(n+1,2)).NE.21) goto 150

          i1=i+1

          IF(i.EQ.n+nr) i1=n+1

          IF(k(i,1).EQ.41.OR.k(i1,1).EQ.41) goto 150

          IF(mju(1).NE.0.AND.i1.LT.mju(1).AND.iabs(k(i1,2)).NE.21)

     &    goto 150

          IF(mju(2).NE.0.AND.i.GT.mju(2).AND.iabs(k(i,2)).NE.21)

     &    goto 150

          pap=sqrt((p(i,1)**2+p(i,2)**2+p(i,3)**2)*(p(i1,1)**2+

     &    p(i1,2)**2+p(i1,3)**2))

          pvp=p(i,1)*p(i1,1)+p(i,2)*p(i1,2)+p(i,3)*p(i1,3)

          pdr=4d0*(pap-pvp)**2/max(1d-6,paru13**2*pap+2d0*(pap-pvp))

          IF(pdr.LT.pdrmin) THEN

            ir=i

            pdrmin=pdr

          ENDIF

  150   CONTINUE


C...Recombine very nearby partons to avoid machine precision problems.

        IF(pdrmin.LT.paru12.AND.ir.EQ.n+nr) THEN

          DO 160 j=1,4

            p(n+1,j)=p(n+1,j)+p(n+nr,j)

  160     CONTINUE

          p(n+1,5)=sqrt(max(0d0,p(n+1,4)**2-p(n+1,1)**2-p(n+1,2)**2-

     &    p(n+1,3)**2))

          nr=nr-1

          goto 140

        ELSEIF(pdrmin.LT.paru12) THEN

          DO 170 j=1,4

            p(ir,j)=p(ir,j)+p(ir+1,j)

  170     CONTINUE

          p(ir,5)=sqrt(max(0d0,p(ir,4)**2-p(ir,1)**2-p(ir,2)**2-

     &    p(ir,3)**2))

          DO 190 i=ir+1,n+nr-1

            k(i,2)=k(i+1,2)

            DO 180 j=1,5

              p(i,j)=p(i+1,j)

  180       CONTINUE

  190     CONTINUE

          IF(ir.EQ.n+nr-1) k(ir,2)=k(n+nr,2)

          nr=nr-1

          IF(mju(1).GT.ir) mju(1)=mju(1)-1

          IF(mju(2).GT.ir) mju(2)=mju(2)-1

          goto 140

        ENDIF

      ENDIF

      ntryr=ntryr+1


C...Reset particle counter. Skip ahead if no junctions are present;

C...this is usually the case!

      nrs=max(5*nr+11,np)

      ntry=0

  200 ntry=ntry+1

      IF(ntry.GT.100.AND.ntryr.LE.4) THEN

        paru12=4d0*paru12

        paru13=2d0*paru13

        goto 140

      ELSEIF(ntry.GT.100) THEN

        CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      i=n+nrs

      mstu(90)=mstu90

      IF(mju(1).EQ.0.AND.mju(2).EQ.0) goto 580

      DO 570 jt=1,2

        njs(jt)=0

        IF(mju(jt).EQ.0) goto 570

        js=3-2*jt


C...Find and sum up momentum on three sides of junction. Check flavours.

        DO 220 iu=1,3

          iju(iu)=0

          DO 210 j=1,5

            pju(iu,j)=0d0

  210     CONTINUE

  220   CONTINUE

        iu=0

        DO 240 i1=n+1+(jt-1)*(nr-1),n+nr+(jt-1)*(1-nr),js

          IF(k(i1,2).NE.21.AND.iu.LE.2) THEN

            iu=iu+1

            iju(iu)=i1

          ENDIF

          DO 230 j=1,4

            pju(iu,j)=pju(iu,j)+p(i1,j)

  230     CONTINUE

  240   CONTINUE

        DO 250 iu=1,3

          pju(iu,5)=sqrt(pju(iu,1)**2+pju(iu,2)**2+pju(iu,3)**2)

  250   CONTINUE

        IF(k(iju(3),2)/100.NE.10*k(iju(1),2)+k(iju(2),2).AND.

     &  k(iju(3),2)/100.NE.10*k(iju(2),2)+k(iju(1),2)) THEN

          CALL pyerrm(12,'(PYSTRF:) unphysical flavour combination')

          IF(mstu(21).GE.1) RETURN

        ENDIF


C...Calculate (approximate) boost to rest frame of junction.

        t12=(pju(1,1)*pju(2,1)+pju(1,2)*pju(2,2)+pju(1,3)*pju(2,3))/

     &  (pju(1,5)*pju(2,5))

        t13=(pju(1,1)*pju(3,1)+pju(1,2)*pju(3,2)+pju(1,3)*pju(3,3))/

     &  (pju(1,5)*pju(3,5))

        t23=(pju(2,1)*pju(3,1)+pju(2,2)*pju(3,2)+pju(2,3)*pju(3,3))/

     &  (pju(2,5)*pju(3,5))

        t11=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t13)/(1d0-t23))

        t22=sqrt((2d0/3d0)*(1d0-t12)*(1d0-t23)/(1d0-t13))

        tsq=sqrt((2d0*t11*t22+t12-1d0)*(1d0+t12))

        t1f=(tsq-t22*(1d0+t12))/(1d0-t12**2)

        t2f=(tsq-t11*(1d0+t12))/(1d0-t12**2)

        DO 260 j=1,3

          tju(j)=-(t1f*pju(1,j)/pju(1,5)+t2f*pju(2,j)/pju(2,5))

  260   CONTINUE

        tju(4)=sqrt(1d0+tju(1)**2+tju(2)**2+tju(3)**2)

        DO 270 iu=1,3

          pju(iu,5)=tju(4)*pju(iu,4)-tju(1)*pju(iu,1)-tju(2)*pju(iu,2)-

     &    tju(3)*pju(iu,3)

  270   CONTINUE


C...Put junction at rest if motion could give inconsistencies.

        IF(pju(1,5)+pju(2,5).GT.pju(1,4)+pju(2,4)) THEN

          DO 280 j=1,3

            tju(j)=0d0

  280     CONTINUE

          tju(4)=1d0

          pju(1,5)=pju(1,4)

          pju(2,5)=pju(2,4)

          pju(3,5)=pju(3,4)

        ENDIF


C...Start preparing for fragmentation of two strings from junction.

        ista=i

        DO 550 iu=1,2

          ns=iju(iu+1)-iju(iu)


C...Junction strings: find longitudinal string directions.

          DO 310 is=1,ns

            is1=iju(iu)+is-1

            is2=iju(iu)+is

            DO 290 j=1,5

              dp(1,j)=0.5d0*p(is1,j)

              IF(is.EQ.1) dp(1,j)=p(is1,j)

              dp(2,j)=0.5d0*p(is2,j)

              IF(is.EQ.ns) dp(2,j)=-pju(iu,j)

  290       CONTINUE

            IF(is.EQ.ns) dp(2,4)=sqrt(pju(iu,1)**2+pju(iu,2)**2+

     &      pju(iu,3)**2)

            IF(is.EQ.ns) dp(2,5)=0d0

            dp(3,5)=dfour(1,1)

            dp(4,5)=dfour(2,2)

            dhkc=dfour(1,2)

            IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN

              dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)

              dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)

              dp(3,5)=0d0

              dp(4,5)=0d0

              dhkc=dfour(1,2)

            ENDIF

            dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))

            dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)

            dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)

            in1=n+nr+4*is-3

            p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))

            DO 300 j=1,4

              p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)

              p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)

  300       CONTINUE

  310     CONTINUE


C...Junction strings: initialize flavour, momentum and starting pos.

          isav=i

          mstu91=mstu(90)

  320     ntry=ntry+1

          IF(ntry.GT.100.AND.ntryr.LE.4) THEN

            paru12=4d0*paru12

            paru13=2d0*paru13

            goto 140

          ELSEIF(ntry.GT.100) THEN

            CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')

            IF(mstu(21).GE.1) RETURN

          ENDIF

          i=isav

          mstu(90)=mstu91

          irankj=0

          ie(1)=k(n+1+(jt/2)*(np-1),3)

          in(4)=n+nr+1

          in(5)=in(4)+1

          in(6)=n+nr+4*ns+1

          DO 340 jq=1,2

            DO 330 in1=n+nr+2+jq,n+nr+4*ns-2+jq,4

              p(in1,1)=2-jq

              p(in1,2)=jq-1

              p(in1,3)=1d0

  330       CONTINUE

  340     CONTINUE

          kfl(1)=k(iju(iu),2)

          px(1)=0d0

          py(1)=0d0

          gam(1)=0d0

          DO 350 j=1,5

            pju(iu+3,j)=0d0

  350     CONTINUE


C...Junction strings: find initial transverse directions.

          DO 360 j=1,4

            dp(1,j)=p(in(4),j)

            dp(2,j)=p(in(4)+1,j)

            dp(3,j)=0d0

            dp(4,j)=0d0

  360     CONTINUE

          dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)

          dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)

          dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)

          dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)

          dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)

          IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0

          IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0

          IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0

          IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0

          dhc12=dfour(1,2)

          dhcx1=dfour(3,1)/dhc12

          dhcx2=dfour(3,2)/dhc12

          dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)

          dhcy1=dfour(4,1)/dhc12

          dhcy2=dfour(4,2)/dhc12

          dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12

          dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)

          DO 370 j=1,4

            dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))

            p(in(6),j)=dp(3,j)

            p(in(6)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-

     &      dhcyx*dp(3,j))

  370     CONTINUE


C...Junction strings: produce new particle, origin.

  380     i=i+1

          IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN

            CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')

            IF(mstu(21).GE.1) RETURN

          ENDIF

          irankj=irankj+1

          k(i,1)=1

          k(i,3)=ie(1)

          k(i,4)=0

          k(i,5)=0


C...Junction strings: generate flavour, hadron, pT, z and Gamma.

  390     CALL pykfdi(kfl(1),0,kfl(3),k(i,2))

          IF(k(i,2).EQ.0) goto 320

          IF(mstj(12).GE.3.AND.irankj.EQ.1.AND.iabs(kfl(1)).LE.10.AND.

     &    iabs(kfl(3)).GT.10) THEN

            IF(pyr(0).GT.parj(19)) goto 390

          ENDIF

          p(i,5)=pymass(k(i,2))

          CALL pyptdi(kfl(1),px(3),py(3))

          pr(1)=p(i,5)**2+(px(1)+px(3))**2+(py(1)+py(3))**2

          CALL pyzdis(kfl(1),kfl(3),pr(1),z)

          IF(iabs(kfl(1)).GE.4.AND.iabs(kfl(1)).LE.8.AND.

     &    mstu(90).LT.8) THEN

            mstu(90)=mstu(90)+1

            mstu(90+mstu(90))=i

            paru(90+mstu(90))=z

          ENDIF

          gam(3)=(1d0-z)*(gam(1)+pr(1)/z)

          DO 400 j=1,3

            in(j)=in(3+j)

  400     CONTINUE


C...Junction strings: stepping within or from 'low' string region easy.

          IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*

     &    p(in(1),5)**2.GE.pr(1)) THEN

            p(in(1)+2,4)=z*p(in(1)+2,3)

            p(in(2)+2,4)=pr(1)/(p(in(1)+2,4)*p(in(1),5)**2)

            DO 410 j=1,4

              p(i,j)=(px(1)+px(3))*p(in(3),j)+(py(1)+py(3))*p(in(3)+1,j)

  410       CONTINUE

            goto 500

          ELSEIF(in(1)+1.EQ.in(2)) THEN

            p(in(2)+2,4)=p(in(2)+2,3)

            p(in(2)+2,1)=1d0

            in(2)=in(2)+4

            IF(in(2).GT.n+nr+4*ns) goto 320

            IF(four(in(1),in(2)).LE.1d-2) THEN

              p(in(1)+2,4)=p(in(1)+2,3)

              p(in(1)+2,1)=0d0

              in(1)=in(1)+4

            ENDIF

          ENDIF


C...Junction strings: find new transverse directions.

  420     IF(in(1).GT.n+nr+4*ns.OR.in(2).GT.n+nr+4*ns.OR.

     &    in(1).GT.in(2)) goto 320

          IF(in(1).NE.in(4).OR.in(2).NE.in(5)) THEN

            DO 430 j=1,4

              dp(1,j)=p(in(1),j)

              dp(2,j)=p(in(2),j)

              dp(3,j)=0d0

              dp(4,j)=0d0

  430       CONTINUE

            dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)

            dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)

            dhc12=dfour(1,2)

            IF(dhc12.LE.1d-2) THEN

              p(in(1)+2,4)=p(in(1)+2,3)

              p(in(1)+2,1)=0d0

              in(1)=in(1)+4

              goto 420

            ENDIF

            in(3)=n+nr+4*ns+5

            dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)

            dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)

            dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)

            IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0

            IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0

            IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0

            IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0

            dhcx1=dfour(3,1)/dhc12

            dhcx2=dfour(3,2)/dhc12

            dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)

            dhcy1=dfour(4,1)/dhc12

            dhcy2=dfour(4,2)/dhc12

            dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12

            dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)

            DO 440 j=1,4

              dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))

              p(in(3),j)=dp(3,j)

              p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-

     &        dhcyx*dp(3,j))

  440       CONTINUE

C...Express pT with respect to new axes, if sensible.

            pxp=-(px(3)*four(in(6),in(3))+py(3)*four(in(6)+1,in(3)))

            pyp=-(px(3)*four(in(6),in(3)+1)+py(3)*four(in(6)+1,in(3)+1))

            IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN

              px(3)=pxp

              py(3)=pyp

            ENDIF

          ENDIF


C...Junction strings: sum up known four-momentum, coefficients for m2.

          DO 470 j=1,4

            dhg(j)=0d0

            p(i,j)=px(1)*p(in(6),j)+py(1)*p(in(6)+1,j)+px(3)*p(in(3),j)+

     &      py(3)*p(in(3)+1,j)

            DO 450 in1=in(4),in(1)-4,4

              p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)

  450       CONTINUE

            DO 460 in2=in(5),in(2)-4,4

              p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)

  460       CONTINUE

  470     CONTINUE

          dhm(1)=four(i,i)

          dhm(2)=2d0*four(i,in(1))

          dhm(3)=2d0*four(i,in(2))

          dhm(4)=2d0*four(in(1),in(2))


C...Junction strings: find coefficients for Gamma expression.

          DO 490 in2=in(1)+1,in(2),4

            DO 480 in1=in(1),in2-1,4

              dhc=2d0*four(in1,in2)

              dhg(1)=dhg(1)+p(in1+2,1)*p(in2+2,1)*dhc

              IF(in1.EQ.in(1)) dhg(2)=dhg(2)-p(in2+2,1)*dhc

              IF(in2.EQ.in(2)) dhg(3)=dhg(3)+p(in1+2,1)*dhc

              IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc

  480       CONTINUE

  490     CONTINUE


C...Junction strings: solve (m2, Gamma) equation system for energies.

          dhs1=dhm(3)*dhg(4)-dhm(4)*dhg(3)

          IF(abs(dhs1).LT.1d-4) goto 320

          dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(2)*dhg(3)-dhg(4)*

     &    (p(i,5)**2-dhm(1))+dhg(2)*dhm(3)

          dhs3=dhm(2)*(gam(3)-dhg(1))-dhg(2)*(p(i,5)**2-dhm(1))

          p(in(2)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/

     &    abs(dhs1)-dhs2/dhs1)

          IF(dhm(2)+dhm(4)*p(in(2)+2,4).LE.0d0) goto 320

          p(in(1)+2,4)=(p(i,5)**2-dhm(1)-dhm(3)*p(in(2)+2,4))/

     &    (dhm(2)+dhm(4)*p(in(2)+2,4))


C...Junction strings: step to new region if necessary.

          IF(p(in(2)+2,4).GT.p(in(2)+2,3)) THEN

            p(in(2)+2,4)=p(in(2)+2,3)

            p(in(2)+2,1)=1d0

            in(2)=in(2)+4

            IF(in(2).GT.n+nr+4*ns) goto 320

            IF(four(in(1),in(2)).LE.1d-2) THEN

              p(in(1)+2,4)=p(in(1)+2,3)

              p(in(1)+2,1)=0d0

              in(1)=in(1)+4

            ENDIF

            goto 420

          ELSEIF(p(in(1)+2,4).GT.p(in(1)+2,3)) THEN

            p(in(1)+2,4)=p(in(1)+2,3)

            p(in(1)+2,1)=0d0

            in(1)=in(1)+js

            goto 820

          ENDIF


C...Junction strings: particle four-momentum, remainder, loop back.

  500     DO 510 j=1,4

            p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+

     &      p(in(2)+2,4)*p(in(2),j)

            pju(iu+3,j)=pju(iu+3,j)+p(i,j)

  510     CONTINUE

          IF(p(i,4).LT.p(i,5)) goto 320

          pju(iu+3,5)=tju(4)*pju(iu+3,4)-tju(1)*pju(iu+3,1)-

     &    tju(2)*pju(iu+3,2)-tju(3)*pju(iu+3,3)

          IF(pju(iu+3,5).LT.pju(iu,5)) THEN

            kfl(1)=-kfl(3)

            px(1)=-px(3)

            py(1)=-py(3)

            gam(1)=gam(3)

            IF(in(3).NE.in(6)) THEN

              DO 520 j=1,4

                p(in(6),j)=p(in(3),j)

                p(in(6)+1,j)=p(in(3)+1,j)

  520         CONTINUE

            ENDIF

            DO 530 jq=1,2

              in(3+jq)=in(jq)

              p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)

              p(in(jq)+2,1)=p(in(jq)+2,1)-(3-2*jq)*p(in(jq)+2,4)

  530       CONTINUE

            goto 380

          ENDIF


C...Junction strings: save quantities left after each string.

          IF(iabs(kfl(1)).GT.10) goto 320

          i=i-1

          kfjh(iu)=kfl(1)

          DO 540 j=1,4

            pju(iu+3,j)=pju(iu+3,j)-p(i+1,j)

  540     CONTINUE

  550   CONTINUE


C...Junction strings: put together to new effective string endpoint.

        njs(jt)=i-ista

        kfjs(jt)=k(k(mju(jt+2),3),2)

        kfls=2*int(pyr(0)+3d0*parj(4)/(1d0+3d0*parj(4)))+1

        IF(kfjh(1).EQ.kfjh(2)) kfls=3

        IF(ista.NE.i) kfjs(jt)=isign(1000*max(iabs(kfjh(1)),

     &  iabs(kfjh(2)))+100*min(iabs(kfjh(1)),iabs(kfjh(2)))+

     &  kfls,kfjh(1))

        DO 560 j=1,4

          pjs(jt,j)=pju(1,j)+pju(2,j)+p(mju(jt),j)

          pjs(jt+2,j)=pju(4,j)+pju(5,j)

  560   CONTINUE

        pjs(jt,5)=sqrt(max(0d0,pjs(jt,4)**2-pjs(jt,1)**2-pjs(jt,2)**2-

     &  pjs(jt,3)**2))

  570 CONTINUE


C...Open versus closed strings. Choose breakup region for latter.

  580 IF(mju(1).NE.0.AND.mju(2).NE.0) THEN

        ns=mju(2)-mju(1)

        nb=mju(1)-n

      ELSEIF(mju(1).NE.0) THEN

        ns=n+nr-mju(1)

        nb=mju(1)-n

      ELSEIF(mju(2).NE.0) THEN

        ns=mju(2)-n

        nb=1

      ELSEIF(iabs(k(n+1,2)).NE.21) THEN

        ns=nr-1

        nb=1

      ELSE

        ns=nr+1

        w2sum=0d0

        DO 590 is=1,nr

          p(n+nr+is,1)=0.5d0*four(n+is,n+is+1-nr*(is/nr))

          w2sum=w2sum+p(n+nr+is,1)

  590   CONTINUE

        w2ran=pyr(0)*w2sum

        nb=0

  600   nb=nb+1

        w2sum=w2sum-p(n+nr+nb,1)

        IF(w2sum.GT.w2ran.AND.nb.LT.nr) goto 600

      ENDIF


C...Find longitudinal string directions (i.e. lightlike four-vectors).

      DO 630 is=1,ns

        is1=n+is+nb-1-nr*((is+nb-2)/nr)

        is2=n+is+nb-nr*((is+nb-1)/nr)

        DO 610 j=1,5

          dp(1,j)=p(is1,j)

          IF(iabs(k(is1,2)).EQ.21) dp(1,j)=0.5d0*dp(1,j)

          IF(is1.EQ.mju(1)) dp(1,j)=pjs(1,j)-pjs(3,j)

          dp(2,j)=p(is2,j)

          IF(iabs(k(is2,2)).EQ.21) dp(2,j)=0.5d0*dp(2,j)

          IF(is2.EQ.mju(2)) dp(2,j)=pjs(2,j)-pjs(4,j)

  610   CONTINUE

        dp(3,5)=dfour(1,1)

        dp(4,5)=dfour(2,2)

        dhkc=dfour(1,2)

        IF(dp(3,5)+2d0*dhkc+dp(4,5).LE.0d0) THEN

          dp(3,5)=dp(1,5)**2

          dp(4,5)=dp(2,5)**2

          dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2+dp(1,5)**2)

          dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2+dp(2,5)**2)

          dhkc=dfour(1,2)

        ENDIF

        dhks=sqrt(dhkc**2-dp(3,5)*dp(4,5))

        dhk1=0.5d0*((dp(4,5)+dhkc)/dhks-1d0)

        dhk2=0.5d0*((dp(3,5)+dhkc)/dhks-1d0)

        in1=n+nr+4*is-3

        p(in1,5)=sqrt(dp(3,5)+2d0*dhkc+dp(4,5))

        DO 620 j=1,4

          p(in1,j)=(1d0+dhk1)*dp(1,j)-dhk2*dp(2,j)

          p(in1+1,j)=(1d0+dhk2)*dp(2,j)-dhk1*dp(1,j)

  620   CONTINUE

  630 CONTINUE


C...Begin initialization: sum up energy, set starting position.

      isav=i

      mstu91=mstu(90)

  640 ntry=ntry+1

      IF(ntry.GT.100.AND.ntryr.LE.4) THEN

        paru12=4d0*paru12

        paru13=2d0*paru13

        goto 140

      ELSEIF(ntry.GT.100) THEN

        CALL pyerrm(14,'(PYSTRF:) caught in infinite loop')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      i=isav

      mstu(90)=mstu91

      DO 660 j=1,4

        p(n+nrs,j)=0d0

        DO 650 is=1,nr

          p(n+nrs,j)=p(n+nrs,j)+p(n+is,j)

  650   CONTINUE

  660 CONTINUE

      DO 680 jt=1,2

        irank(jt)=0

        IF(mju(jt).NE.0) irank(jt)=njs(jt)

        IF(ns.GT.nr) irank(jt)=1

        ie(jt)=k(n+1+(jt/2)*(np-1),3)

        in(3*jt+1)=n+nr+1+4*(jt/2)*(ns-1)

        in(3*jt+2)=in(3*jt+1)+1

        in(3*jt+3)=n+nr+4*ns+2*jt-1

        DO 670 in1=n+nr+2+jt,n+nr+4*ns-2+jt,4

          p(in1,1)=2-jt

          p(in1,2)=jt-1

          p(in1,3)=1d0

  670   CONTINUE

  680 CONTINUE


C...Initialize flavour and pT variables for open string.

      IF(ns.LT.nr) THEN

        px(1)=0d0

        py(1)=0d0

        IF(ns.EQ.1.AND.mju(1)+mju(2).EQ.0) CALL pyptdi(0,px(1),py(1))

        px(2)=-px(1)

        py(2)=-py(1)

        DO 690 jt=1,2

          kfl(jt)=k(ie(jt),2)

          IF(mju(jt).NE.0) kfl(jt)=kfjs(jt)

          mstj(93)=1

          pmq(jt)=pymass(kfl(jt))

          gam(jt)=0d0

  690   CONTINUE


C...Closed string: random initial breakup flavour, pT and vertex.

      ELSE

        kfl(3)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)

        CALL pykfdi(kfl(3),0,kfl(1),kdump)

        kfl(2)=-kfl(1)

        IF(iabs(kfl(1)).GT.10.AND.pyr(0).GT.0.5d0) THEN

          kfl(2)=-(kfl(1)+isign(10000,kfl(1)))

        ELSEIF(iabs(kfl(1)).GT.10) THEN

          kfl(1)=-(kfl(2)+isign(10000,kfl(2)))

        ENDIF

        CALL pyptdi(kfl(1),px(1),py(1))

        px(2)=-px(1)

        py(2)=-py(1)

        pr3=min(25d0,0.1d0*p(n+nr+1,5)**2)

  700   CALL pyzdis(kfl(1),kfl(2),pr3,z)

        zr=pr3/(z*p(n+nr+1,5)**2)

        IF(zr.GE.1d0) goto 700

        DO 710 jt=1,2

          mstj(93)=1

          pmq(jt)=pymass(kfl(jt))

          gam(jt)=pr3*(1d0-z)/z

          in1=n+nr+3+4*(jt/2)*(ns-1)

          p(in1,jt)=1d0-z

          p(in1,3-jt)=jt-1

          p(in1,3)=(2-jt)*(1d0-z)+(jt-1)*z

          p(in1+1,jt)=zr

          p(in1+1,3-jt)=2-jt

          p(in1+1,3)=(2-jt)*(1d0-zr)+(jt-1)*zr

  710   CONTINUE

      ENDIF


C...Find initial transverse directions (i.e. spacelike four-vectors).

      DO 750 jt=1,2

        IF(jt.EQ.1.OR.ns.EQ.nr-1) THEN

          in1=in(3*jt+1)

          in3=in(3*jt+3)

          DO 720 j=1,4

            dp(1,j)=p(in1,j)

            dp(2,j)=p(in1+1,j)

            dp(3,j)=0d0

            dp(4,j)=0d0

  720     CONTINUE

          dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)

          dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)

          dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)

          dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)

          dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)

          IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0

          IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0

          IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0

          IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0

          dhc12=dfour(1,2)

          dhcx1=dfour(3,1)/dhc12

          dhcx2=dfour(3,2)/dhc12

          dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)

          dhcy1=dfour(4,1)/dhc12

          dhcy2=dfour(4,2)/dhc12

          dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12

          dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)

          DO 730 j=1,4

            dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))

            p(in3,j)=dp(3,j)

            p(in3+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-

     &      dhcyx*dp(3,j))

  730     CONTINUE

        ELSE

          DO 740 j=1,4

            p(in3+2,j)=p(in3,j)

            p(in3+3,j)=p(in3+1,j)

  740     CONTINUE

        ENDIF

  750 CONTINUE


C...Remove energy used up in junction string fragmentation.

      IF(mju(1)+mju(2).GT.0) THEN

        DO 770 jt=1,2

          IF(njs(jt).EQ.0) goto 770

          DO 760 j=1,4

            p(n+nrs,j)=p(n+nrs,j)-pjs(jt+2,j)

  760     CONTINUE

  770   CONTINUE

      ENDIF


C...Produce new particle: side, origin.

  780 i=i+1

      IF(2*i-nsav.GE.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYSTRF:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      jt=1.5d0+pyr(0)

      IF(iabs(kfl(3-jt)).GT.10) jt=3-jt

      IF(iabs(kfl(3-jt)).GE.4.AND.iabs(kfl(3-jt)).LE.8) jt=3-jt

      jr=3-jt

      js=3-2*jt

      irank(jt)=irank(jt)+1

      k(i,1)=1

      k(i,3)=ie(jt)

      k(i,4)=0

      k(i,5)=0


C...Generate flavour, hadron and pT.

  790 CALL pykfdi(kfl(jt),0,kfl(3),k(i,2))

      IF(k(i,2).EQ.0) goto 640

      IF(mstj(12).GE.3.AND.irank(jt).EQ.1.AND.iabs(kfl(jt)).LE.10.AND.

     &iabs(kfl(3)).GT.10) THEN

        IF(pyr(0).GT.parj(19)) goto 790

      ENDIF

      p(i,5)=pymass(k(i,2))

      CALL pyptdi(kfl(jt),px(3),py(3))

      pr(jt)=p(i,5)**2+(px(jt)+px(3))**2+(py(jt)+py(3))**2


C...Final hadrons for small invariant mass.

      mstj(93)=1

      pmq(3)=pymass(kfl(3))

      parjst=parj(33)

      IF(mstj(11).EQ.2) parjst=parj(34)

      wmin=parjst+pmq(1)+pmq(2)+parj(36)*pmq(3)

      IF(iabs(kfl(jt)).GT.10.AND.iabs(kfl(3)).GT.10) wmin=

     &wmin-0.5d0*parj(36)*pmq(3)

      wrem2=four(n+nrs,n+nrs)

      IF(wrem2.LT.0.10d0) goto 640

      IF(wrem2.LT.max(wmin*(1d0+(2d0*pyr(0)-1d0)*parj(37)),

     &parj(32)+pmq(1)+pmq(2))**2) goto 940


C...Choose z, which gives Gamma. Shift z for heavy flavours.

      CALL pyzdis(kfl(jt),kfl(3),pr(jt),z)

      IF(iabs(kfl(jt)).GE.4.AND.iabs(kfl(jt)).LE.8.AND.

     &mstu(90).LT.8) THEN

        mstu(90)=mstu(90)+1

        mstu(90+mstu(90))=i

        paru(90+mstu(90))=z

      ENDIF

      kfl1a=iabs(kfl(1))

      kfl2a=iabs(kfl(2))

      IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),

     &mod(kfl2a/1000,10)).GE.4) THEN

        pr(jr)=(pmq(jr)+pmq(3))**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2

        pw12=sqrt(max(0d0,(wrem2-pr(1)-pr(2))**2-4d0*pr(1)*pr(2)))

        z=(wrem2+pr(jt)-pr(jr)+pw12*(2d0*z-1d0))/(2d0*wrem2)

        pr(jr)=(pmq(jr)+parjst)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2

        IF((1d0-z)*(wrem2-pr(jt)/z).LT.pr(jr)) goto 940

      ENDIF

      gam(3)=(1d0-z)*(gam(jt)+pr(jt)/z)

      DO 800 j=1,3

        in(j)=in(3*jt+j)

  800 CONTINUE


C...Stepping within or from 'low' string region easy.

      IF(in(1)+1.EQ.in(2).AND.z*p(in(1)+2,3)*p(in(2)+2,3)*

     &p(in(1),5)**2.GE.pr(jt)) THEN

        p(in(jt)+2,4)=z*p(in(jt)+2,3)

        p(in(jr)+2,4)=pr(jt)/(p(in(jt)+2,4)*p(in(1),5)**2)

        DO 810 j=1,4

          p(i,j)=(px(jt)+px(3))*p(in(3),j)+(py(jt)+py(3))*p(in(3)+1,j)

  810   CONTINUE

        goto 900

      ELSEIF(in(1)+1.EQ.in(2)) THEN

        p(in(jr)+2,4)=p(in(jr)+2,3)

        p(in(jr)+2,jt)=1d0

        in(jr)=in(jr)+4*js

        IF(js*in(jr).GT.js*in(4*jr)) goto 640

        IF(four(in(1),in(2)).LE.1d-2) THEN

          p(in(jt)+2,4)=p(in(jt)+2,3)

          p(in(jt)+2,jt)=0d0

          in(jt)=in(jt)+4*js

        ENDIF

      ENDIF


C...Find new transverse directions (i.e. spacelike string vectors).

  820 IF(js*in(1).GT.js*in(3*jr+1).OR.js*in(2).GT.js*in(3*jr+2).OR.

     &in(1).GT.in(2)) goto 640

      IF(in(1).NE.in(3*jt+1).OR.in(2).NE.in(3*jt+2)) THEN

        DO 830 j=1,4

          dp(1,j)=p(in(1),j)

          dp(2,j)=p(in(2),j)

          dp(3,j)=0d0

          dp(4,j)=0d0

  830   CONTINUE

        dp(1,4)=sqrt(dp(1,1)**2+dp(1,2)**2+dp(1,3)**2)

        dp(2,4)=sqrt(dp(2,1)**2+dp(2,2)**2+dp(2,3)**2)

        dhc12=dfour(1,2)

        IF(dhc12.LE.1d-2) THEN

          p(in(jt)+2,4)=p(in(jt)+2,3)

          p(in(jt)+2,jt)=0d0

          in(jt)=in(jt)+4*js

          goto 820

        ENDIF

        in(3)=n+nr+4*ns+5

        dp(5,1)=dp(1,1)/dp(1,4)-dp(2,1)/dp(2,4)

        dp(5,2)=dp(1,2)/dp(1,4)-dp(2,2)/dp(2,4)

        dp(5,3)=dp(1,3)/dp(1,4)-dp(2,3)/dp(2,4)

        IF(dp(5,1)**2.LE.dp(5,2)**2+dp(5,3)**2) dp(3,1)=1d0

        IF(dp(5,1)**2.GT.dp(5,2)**2+dp(5,3)**2) dp(3,3)=1d0

        IF(dp(5,2)**2.LE.dp(5,1)**2+dp(5,3)**2) dp(4,2)=1d0

        IF(dp(5,2)**2.GT.dp(5,1)**2+dp(5,3)**2) dp(4,3)=1d0

        dhcx1=dfour(3,1)/dhc12

        dhcx2=dfour(3,2)/dhc12

        dhcxx=1d0/sqrt(1d0+2d0*dhcx1*dhcx2*dhc12)

        dhcy1=dfour(4,1)/dhc12

        dhcy2=dfour(4,2)/dhc12

        dhcyx=dhcxx*(dhcx1*dhcy2+dhcx2*dhcy1)*dhc12

        dhcyy=1d0/sqrt(1d0+2d0*dhcy1*dhcy2*dhc12-dhcyx**2)

        DO 840 j=1,4

          dp(3,j)=dhcxx*(dp(3,j)-dhcx2*dp(1,j)-dhcx1*dp(2,j))

          p(in(3),j)=dp(3,j)

          p(in(3)+1,j)=dhcyy*(dp(4,j)-dhcy2*dp(1,j)-dhcy1*dp(2,j)-

     &    dhcyx*dp(3,j))

  840   CONTINUE

C...Express pT with respect to new axes, if sensible.

        pxp=-(px(3)*four(in(3*jt+3),in(3))+py(3)*

     &  four(in(3*jt+3)+1,in(3)))

        pyp=-(px(3)*four(in(3*jt+3),in(3)+1)+py(3)*

     &  four(in(3*jt+3)+1,in(3)+1))

        IF(abs(pxp**2+pyp**2-px(3)**2-py(3)**2).LT.0.01d0) THEN

          px(3)=pxp

          py(3)=pyp

        ENDIF

      ENDIF


C...Sum up known four-momentum. Gives coefficients for m2 expression.

      DO 870 j=1,4

        dhg(j)=0d0

        p(i,j)=px(jt)*p(in(3*jt+3),j)+py(jt)*p(in(3*jt+3)+1,j)+

     &  px(3)*p(in(3),j)+py(3)*p(in(3)+1,j)

        DO 850 in1=in(3*jt+1),in(1)-4*js,4*js

          p(i,j)=p(i,j)+p(in1+2,3)*p(in1,j)

  850   CONTINUE

        DO 860 in2=in(3*jt+2),in(2)-4*js,4*js

          p(i,j)=p(i,j)+p(in2+2,3)*p(in2,j)

  860   CONTINUE

  870 CONTINUE

      dhm(1)=four(i,i)

      dhm(2)=2d0*four(i,in(1))

      dhm(3)=2d0*four(i,in(2))

      dhm(4)=2d0*four(in(1),in(2))


C...Find coefficients for Gamma expression.

      DO 890 in2=in(1)+1,in(2),4

        DO 880 in1=in(1),in2-1,4

          dhc=2d0*four(in1,in2)

          dhg(1)=dhg(1)+p(in1+2,jt)*p(in2+2,jt)*dhc

          IF(in1.EQ.in(1)) dhg(2)=dhg(2)-js*p(in2+2,jt)*dhc

          IF(in2.EQ.in(2)) dhg(3)=dhg(3)+js*p(in1+2,jt)*dhc

          IF(in1.EQ.in(1).AND.in2.EQ.in(2)) dhg(4)=dhg(4)-dhc

  880   CONTINUE

  890 CONTINUE


C...Solve (m2, Gamma) equation system for energies taken.

      dhs1=dhm(jr+1)*dhg(4)-dhm(4)*dhg(jr+1)

      IF(abs(dhs1).LT.1d-4) goto 640

      dhs2=dhm(4)*(gam(3)-dhg(1))-dhm(jt+1)*dhg(jr+1)-dhg(4)*

     &(p(i,5)**2-dhm(1))+dhg(jt+1)*dhm(jr+1)

      dhs3=dhm(jt+1)*(gam(3)-dhg(1))-dhg(jt+1)*(p(i,5)**2-dhm(1))

      p(in(jr)+2,4)=0.5d0*(sqrt(max(0d0,dhs2**2-4d0*dhs1*dhs3))/

     &abs(dhs1)-dhs2/dhs1)

      IF(dhm(jt+1)+dhm(4)*p(in(jr)+2,4).LE.0d0) goto 640

      p(in(jt)+2,4)=(p(i,5)**2-dhm(1)-dhm(jr+1)*p(in(jr)+2,4))/

     &(dhm(jt+1)+dhm(4)*p(in(jr)+2,4))


C...Step to new region if necessary.

      IF(p(in(jr)+2,4).GT.p(in(jr)+2,3)) THEN

        p(in(jr)+2,4)=p(in(jr)+2,3)

        p(in(jr)+2,jt)=1d0

        in(jr)=in(jr)+4*js

        IF(js*in(jr).GT.js*in(4*jr)) goto 640

        IF(four(in(1),in(2)).LE.1d-2) THEN

          p(in(jt)+2,4)=p(in(jt)+2,3)

          p(in(jt)+2,jt)=0d0

          in(jt)=in(jt)+4*js

        ENDIF

        goto 820

      ELSEIF(p(in(jt)+2,4).GT.p(in(jt)+2,3)) THEN

        p(in(jt)+2,4)=p(in(jt)+2,3)

        p(in(jt)+2,jt)=0d0

        in(jt)=in(jt)+4*js

        goto 820

      ENDIF


C...Four-momentum of particle. Remaining quantities. Loop back.

  900 DO 910 j=1,4

        p(i,j)=p(i,j)+p(in(1)+2,4)*p(in(1),j)+p(in(2)+2,4)*p(in(2),j)

        p(n+nrs,j)=p(n+nrs,j)-p(i,j)

  910 CONTINUE

      IF(p(i,4).LT.p(i,5)) goto 640

      kfl(jt)=-kfl(3)

      pmq(jt)=pmq(3)

      px(jt)=-px(3)

      py(jt)=-py(3)

      gam(jt)=gam(3)

      IF(in(3).NE.in(3*jt+3)) THEN

        DO 920 j=1,4

          p(in(3*jt+3),j)=p(in(3),j)

          p(in(3*jt+3)+1,j)=p(in(3)+1,j)

  920   CONTINUE

      ENDIF

      DO 930 jq=1,2

        in(3*jt+jq)=in(jq)

        p(in(jq)+2,3)=p(in(jq)+2,3)-p(in(jq)+2,4)

        p(in(jq)+2,jt)=p(in(jq)+2,jt)-js*(3-2*jq)*p(in(jq)+2,4)

  930 CONTINUE

      goto 780


C...Final hadron: side, flavour, hadron, mass.

  940 i=i+1

      k(i,1)=1

      k(i,3)=ie(jr)

      k(i,4)=0

      k(i,5)=0

      CALL pykfdi(kfl(jr),-kfl(3),kfldmp,k(i,2))

      IF(k(i,2).EQ.0) goto 640

      p(i,5)=pymass(k(i,2))

      pr(jr)=p(i,5)**2+(px(jr)-px(3))**2+(py(jr)-py(3))**2


C...Final two hadrons: find common setup of four-vectors.

      jq=1

      IF(p(in(4)+2,3)*p(in(5)+2,3)*four(in(4),in(5)).LT.p(in(7),3)*

     &p(in(8),3)*four(in(7),in(8))) jq=2

      dhc12=four(in(3*jq+1),in(3*jq+2))

      dhr1=four(n+nrs,in(3*jq+2))/dhc12

      dhr2=four(n+nrs,in(3*jq+1))/dhc12

      IF(in(4).NE.in(7).OR.in(5).NE.in(8)) THEN

        px(3-jq)=-four(n+nrs,in(3*jq+3))-px(jq)

        py(3-jq)=-four(n+nrs,in(3*jq+3)+1)-py(jq)

        pr(3-jq)=p(i+(jt+jq-3)**2-1,5)**2+(px(3-jq)+(2*jq-3)*js*

     &  px(3))**2+(py(3-jq)+(2*jq-3)*js*py(3))**2

      ENDIF


C...Solve kinematics for final two hadrons, if possible.

      wrem2=wrem2+(px(1)+px(2))**2+(py(1)+py(2))**2

      fd=(sqrt(pr(1))+sqrt(pr(2)))/sqrt(wrem2)

      IF(mju(1)+mju(2).NE.0.AND.i.EQ.isav+2.AND.fd.GE.1d0) goto 200

      IF(fd.GE.1d0) goto 640

      fa=wrem2+pr(jt)-pr(jr)

      IF(mstj(11).NE.2) prev=0.5d0*exp(max(-50d0,log(fd)*parj(38)*

     &(pr(1)+pr(2))**2))

      IF(mstj(11).EQ.2) prev=0.5d0*fd**parj(39)

      fb=sign(sqrt(max(0d0,fa**2-4d0*wrem2*pr(jt))),js*(pyr(0)-prev))

      kfl1a=iabs(kfl(1))

      kfl2a=iabs(kfl(2))

      IF(max(mod(kfl1a,10),mod(kfl1a/1000,10),mod(kfl2a,10),

     &mod(kfl2a/1000,10)).GE.6) fb=sign(sqrt(max(0d0,fa**2-

     &4d0*wrem2*pr(jt))),dble(js))

      DO 950 j=1,4

        p(i-1,j)=(px(jt)+px(3))*p(in(3*jq+3),j)+(py(jt)+py(3))*

     &  p(in(3*jq+3)+1,j)+0.5d0*(dhr1*(fa+fb)*p(in(3*jq+1),j)+

     &  dhr2*(fa-fb)*p(in(3*jq+2),j))/wrem2

        p(i,j)=p(n+nrs,j)-p(i-1,j)

  950 CONTINUE

      IF(p(i-1,4).LT.p(i-1,5).OR.p(i,4).LT.p(i,5)) goto 640


C...Mark jets as fragmented and give daughter pointers.

      n=i-nrs+1

      DO 960 i=nsav+1,nsav+np

        im=k(i,3)

        k(im,1)=k(im,1)+10

        IF(mstu(16).NE.2) THEN

          k(im,4)=nsav+1

          k(im,5)=nsav+1

        ELSE

          k(im,4)=nsav+2

          k(im,5)=n

        ENDIF

  960 CONTINUE


C...Document string system. Move up particles.

      nsav=nsav+1

      k(nsav,1)=11

      k(nsav,2)=92

      k(nsav,3)=ip

      k(nsav,4)=nsav+1

      k(nsav,5)=n

      DO 970 j=1,4

        p(nsav,j)=dps(j)

        v(nsav,j)=v(ip,j)

  970 CONTINUE

      p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))

      v(nsav,5)=0d0

      DO 990 i=nsav+1,n

        DO 980 j=1,5

          k(i,j)=k(i+nrs-1,j)

          p(i,j)=p(i+nrs-1,j)

          v(i,j)=0d0

  980   CONTINUE

  990 CONTINUE

      mstu91=mstu(90)

      DO 1000 iz=mstu90+1,mstu91

        mstu9t(iz)=mstu(90+iz)-nrs+1-nsav+n

        paru9t(iz)=paru(90+iz)

 1000 CONTINUE

      mstu(90)=mstu90


C...Order particles in rank along the chain. Update mother pointer.

      DO 1020 i=nsav+1,n

        DO 1010 j=1,5

          k(i-nsav+n,j)=k(i,j)

          p(i-nsav+n,j)=p(i,j)

 1010   CONTINUE

 1020 CONTINUE

      i1=nsav

      DO 1050 i=n+1,2*n-nsav

        IF(k(i,3).NE.ie(1)) goto 1050

        i1=i1+1

        DO 1030 j=1,5

          k(i1,j)=k(i,j)

          p(i1,j)=p(i,j)

 1030   CONTINUE

        IF(mstu(16).NE.2) k(i1,3)=nsav

        DO 1040 iz=mstu90+1,mstu91

          IF(mstu9t(iz).EQ.i) THEN

            mstu(90)=mstu(90)+1

            mstu(90+mstu(90))=i1

            paru(90+mstu(90))=paru9t(iz)

          ENDIF

 1040   CONTINUE

 1050 CONTINUE

      DO 1080 i=2*n-nsav,n+1,-1

        IF(k(i,3).EQ.ie(1)) goto 1080

        i1=i1+1

        DO 1060 j=1,5

          k(i1,j)=k(i,j)

          p(i1,j)=p(i,j)

 1060   CONTINUE

        IF(mstu(16).NE.2) k(i1,3)=nsav

        DO 1070 iz=mstu90+1,mstu91

          IF(mstu9t(iz).EQ.i) THEN

            mstu(90)=mstu(90)+1

            mstu(90+mstu(90))=i1

            paru(90+mstu(90))=paru9t(iz)

          ENDIF

 1070   CONTINUE

 1080 CONTINUE


C...Boost back particle system. Set production vertices.

      IF(mbst.EQ.0) THEN

        mstu(33)=1

        CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),

     &  dps(3)/dps(4))

      ELSE

        DO 1090 i=nsav+1,n

          hhpmt=p(i,1)**2+p(i,2)**2+p(i,5)**2

          IF(p(i,3).GT.0d0) THEN

            hhpez=(p(i,4)+p(i,3))*hhbz

            p(i,3)=0.5d0*(hhpez-hhpmt/hhpez)

            p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)

          ELSE

            hhpez=(p(i,4)-p(i,3))/hhbz

            p(i,3)=-0.5d0*(hhpez-hhpmt/hhpez)

            p(i,4)=0.5d0*(hhpez+hhpmt/hhpez)

          ENDIF

 1090   CONTINUE

      ENDIF

      DO 1110 i=nsav+1,n

        DO 1100 j=1,4

          v(i,j)=v(ip,j)

 1100   CONTINUE

 1110 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYINDF

C...Handles the fragmentation of a jet system (or a single

C...jet) according to independent fragmentation models.


      SUBROUTINE pyindf(IP)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension dps(5),psi(4),nfi(3),nfl(3),ifet(3),kflf(3),

     &kflo(2),pxo(2),pyo(2),wo(2)


C...Reset counters. Identify parton system and take copy. Check flavour.

      nsav=n

      mstu90=mstu(90)

      njet=0

      kqsum=0

      DO 100 j=1,5

        dps(j)=0d0

  100 CONTINUE

      i=ip-1

  110 i=i+1

      IF(i.GT.min(n,mstu(4)-mstu(32))) THEN

        CALL pyerrm(12,'(PYINDF:) failed to reconstruct jet system')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(k(i,1).NE.1.AND.k(i,1).NE.2) goto 110

      kc=pycomp(k(i,2))

      IF(kc.EQ.0) goto 110

      kq=kchg(kc,2)*isign(1,k(i,2))

      IF(kq.EQ.0) goto 110

      njet=njet+1

      IF(kq.NE.2) kqsum=kqsum+kq

      DO 120 j=1,5

        k(nsav+njet,j)=k(i,j)

        p(nsav+njet,j)=p(i,j)

        dps(j)=dps(j)+p(i,j)

  120 CONTINUE

      k(nsav+njet,3)=i

      IF(k(i,1).EQ.2.OR.(mstj(3).LE.5.AND.n.GT.i.AND.

     &k(i+1,1).EQ.2)) goto 110

      IF(njet.NE.1.AND.kqsum.NE.0) THEN

        CALL pyerrm(12,'(PYINDF:) unphysical flavour combination')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Boost copied system to CM frame. Find CM energy and sum flavours.

      IF(njet.NE.1) THEN

        mstu(33)=1

        CALL pyrobo(nsav+1,nsav+njet,0d0,0d0,-dps(1)/dps(4),

     &  -dps(2)/dps(4),-dps(3)/dps(4))

      ENDIF

      pecm=0d0

      DO 130 j=1,3

        nfi(j)=0

  130 CONTINUE

      DO 140 i=nsav+1,nsav+njet

        pecm=pecm+p(i,4)

        kfa=iabs(k(i,2))

        IF(kfa.LE.3) THEN

          nfi(kfa)=nfi(kfa)+isign(1,k(i,2))

        ELSEIF(kfa.GT.1000) THEN

          kfla=mod(kfa/1000,10)

          kflb=mod(kfa/100,10)

          IF(kfla.LE.3) nfi(kfla)=nfi(kfla)+isign(1,k(i,2))

          IF(kflb.LE.3) nfi(kflb)=nfi(kflb)+isign(1,k(i,2))

        ENDIF

  140 CONTINUE


C...Loop over attempts made. Reset counters.

      ntry=0

  150 ntry=ntry+1

      IF(ntry.GT.200) THEN

        CALL pyerrm(14,'(PYINDF:) caught in infinite loop')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      n=nsav+njet

      mstu(90)=mstu90

      DO 160 j=1,3

        nfl(j)=nfi(j)

        ifet(j)=0

        kflf(j)=0

  160 CONTINUE


C...Loop over jets to be fragmented.

      DO 230 ip1=nsav+1,nsav+njet

        mstj(91)=0

        nsav1=n

        mstu91=mstu(90)


C...Initial flavour and momentum values. Jet along +z axis.

        kflh=iabs(k(ip1,2))

        IF(kflh.GT.10) kflh=mod(kflh/1000,10)

        kflo(2)=0

        wf=p(ip1,4)+sqrt(p(ip1,1)**2+p(ip1,2)**2+p(ip1,3)**2)


C...Initial values for quark or diquark jet.

  170   IF(iabs(k(ip1,2)).NE.21) THEN

          nstr=1

          kflo(1)=k(ip1,2)

          CALL pyptdi(0,pxo(1),pyo(1))

          wo(1)=wf


C...Initial values for gluon treated like random quark jet.

        ELSEIF(mstj(2).LE.2) THEN

          nstr=1

          IF(mstj(2).EQ.2) mstj(91)=1

          kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)

          CALL pyptdi(0,pxo(1),pyo(1))

          wo(1)=wf


C...Initial values for gluon treated like quark-antiquark jet pair,

C...sharing energy according to Altarelli-Parisi splitting function.

        ELSE

          nstr=2

          IF(mstj(2).EQ.4) mstj(91)=1

          kflo(1)=int(1d0+(2d0+parj(2))*pyr(0))*(-1)**int(pyr(0)+0.5d0)

          kflo(2)=-kflo(1)

          CALL pyptdi(0,pxo(1),pyo(1))

          pxo(2)=-pxo(1)

          pyo(2)=-pyo(1)

          wo(1)=wf*pyr(0)**(1d0/3d0)

          wo(2)=wf-wo(1)

        ENDIF


C...Initial values for rank, flavour, pT and W+.

        DO 220 istr=1,nstr

  180     i=n

          mstu(90)=mstu91

          irank=0

          kfl1=kflo(istr)

          px1=pxo(istr)

          py1=pyo(istr)

          w=wo(istr)


C...New hadron. Generate flavour and hadron species.

  190     i=i+1

          IF(i.GE.mstu(4)-mstu(32)-njet-5) THEN

            CALL pyerrm(11,'(PYINDF:) no more memory left in PYJETS')

            IF(mstu(21).GE.1) RETURN

          ENDIF

          irank=irank+1

          k(i,1)=1

          k(i,3)=ip1

          k(i,4)=0

          k(i,5)=0

  200     CALL pykfdi(kfl1,0,kfl2,k(i,2))

          IF(k(i,2).EQ.0) goto 180

          IF(mstj(12).GE.3.AND.irank.EQ.1.AND.iabs(kfl1).LE.10.AND.

     &    iabs(kfl2).GT.10) THEN

            IF(pyr(0).GT.parj(19)) goto 200

          ENDIF


C...Find hadron mass. Generate four-momentum.

          p(i,5)=pymass(k(i,2))

          CALL pyptdi(kfl1,px2,py2)

          p(i,1)=px1+px2

          p(i,2)=py1+py2

          pr=p(i,5)**2+p(i,1)**2+p(i,2)**2

          CALL pyzdis(kfl1,kfl2,pr,z)

          mzsav=0

          IF(iabs(kfl1).GE.4.AND.iabs(kfl1).LE.8.AND.mstu(90).LT.8) THEN

            mzsav=1

            mstu(90)=mstu(90)+1

            mstu(90+mstu(90))=i

            paru(90+mstu(90))=z

          ENDIF

          p(i,3)=0.5d0*(z*w-pr/max(1d-4,z*w))

          p(i,4)=0.5d0*(z*w+pr/max(1d-4,z*w))

          IF(mstj(3).GE.1.AND.irank.EQ.1.AND.kflh.GE.4.AND.

     &    p(i,3).LE.0.001d0) THEN

            IF(w.GE.p(i,5)+0.5d0*parj(32)) goto 180

            p(i,3)=0.0001d0

            p(i,4)=sqrt(pr)

            z=p(i,4)/w

          ENDIF


C...Remaining flavour and momentum.

          kfl1=-kfl2

          px1=-px2

          py1=-py2

          w=(1d0-z)*w

          DO 210 j=1,5

            v(i,j)=0d0

  210     CONTINUE


C...Check if pL acceptable. Go back for new hadron if enough energy.

          IF(mstj(3).GE.0.AND.p(i,3).LT.0d0) THEN

            i=i-1

            IF(mzsav.EQ.1) mstu(90)=mstu(90)-1

          ENDIF

          IF(w.GT.parj(31)) goto 190

          n=i

  220   CONTINUE

        IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) wf=wf+0.1d0*parj(32)

        IF(mod(mstj(3),5).EQ.4.AND.n.EQ.nsav1) goto 170


C...Rotate jet to new direction.

        the=pyangl(p(ip1,3),sqrt(p(ip1,1)**2+p(ip1,2)**2))

        phi=pyangl(p(ip1,1),p(ip1,2))

        mstu(33)=1

        CALL pyrobo(nsav1+1,n,the,phi,0d0,0d0,0d0)

        k(k(ip1,3),4)=nsav1+1

        k(k(ip1,3),5)=n


C...End of jet generation loop. Skip conservation in some cases.

  230 CONTINUE

      IF(njet.EQ.1.OR.mstj(3).LE.0) goto 490

      IF(mod(mstj(3),5).NE.0.AND.n-nsav-njet.LT.2) goto 150


C...Subtract off produced hadron flavours, finished if zero.

      DO 240 i=nsav+njet+1,n

        kfa=iabs(k(i,2))

        kfla=mod(kfa/1000,10)

        kflb=mod(kfa/100,10)

        kflc=mod(kfa/10,10)

        IF(kfla.EQ.0) THEN

          IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))*(-1)**kflb

          IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(i,2))*(-1)**kflb

        ELSE

          IF(kfla.LE.3) nfl(kfla)=nfl(kfla)-isign(1,k(i,2))

          IF(kflb.LE.3) nfl(kflb)=nfl(kflb)-isign(1,k(i,2))

          IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isign(1,k(i,2))

        ENDIF

  240 CONTINUE

      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+

     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3

      IF(nreq.EQ.0) goto 320


C...Take away flavour of low-momentum particles until enough freedom.

      nrem=0

  250 irem=0

      p2min=pecm**2

      DO 260 i=nsav+njet+1,n

        p2=p(i,1)**2+p(i,2)**2+p(i,3)**2

        IF(k(i,1).EQ.1.AND.p2.LT.p2min) irem=i

        IF(k(i,1).EQ.1.AND.p2.LT.p2min) p2min=p2

  260 CONTINUE

      IF(irem.EQ.0) goto 150

      k(irem,1)=7

      kfa=iabs(k(irem,2))

      kfla=mod(kfa/1000,10)

      kflb=mod(kfa/100,10)

      kflc=mod(kfa/10,10)

      IF(kfla.GE.4.OR.kflb.GE.4) k(irem,1)=8

      IF(k(irem,1).EQ.8) goto 250

      IF(kfla.EQ.0) THEN

        isgn=isign(1,k(irem,2))*(-1)**kflb

        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isgn

        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)-isgn

      ELSE

        IF(kfla.LE.3) nfl(kfla)=nfl(kfla)+isign(1,k(irem,2))

        IF(kflb.LE.3) nfl(kflb)=nfl(kflb)+isign(1,k(irem,2))

        IF(kflc.LE.3) nfl(kflc)=nfl(kflc)+isign(1,k(irem,2))

      ENDIF

      nrem=nrem+1

      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+

     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3

      IF(nreq.GT.nrem) goto 250

      DO 270 i=nsav+njet+1,n

        IF(k(i,1).EQ.8) k(i,1)=1

  270 CONTINUE


C...Find combination of existing and new flavours for hadron.

  280 nfet=2

      IF(nfl(1)+nfl(2)+nfl(3).NE.0) nfet=3

      IF(nreq.LT.nrem) nfet=1

      IF(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)).EQ.0) nfet=0

      DO 290 j=1,nfet

        ifet(j)=1+(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3)))*pyr(0)

        kflf(j)=isign(1,nfl(1))

        IF(ifet(j).GT.iabs(nfl(1))) kflf(j)=isign(2,nfl(2))

        IF(ifet(j).GT.iabs(nfl(1))+iabs(nfl(2))) kflf(j)=isign(3,nfl(3))

  290 CONTINUE

      IF(nfet.EQ.2.AND.(ifet(1).EQ.ifet(2).OR.kflf(1)*kflf(2).GT.0))

     &goto 280

      IF(nfet.EQ.3.AND.(ifet(1).EQ.ifet(2).OR.ifet(1).EQ.ifet(3).OR.

     &ifet(2).EQ.ifet(3).OR.kflf(1)*kflf(2).LT.0.OR.kflf(1)*kflf(3)

     &.LT.0.OR.kflf(1)*(nfl(1)+nfl(2)+nfl(3)).LT.0)) goto 280

      IF(nfet.EQ.0) kflf(1)=1+int((2d0+parj(2))*pyr(0))

      IF(nfet.EQ.0) kflf(2)=-kflf(1)

      IF(nfet.EQ.1) kflf(2)=isign(1+int((2d0+parj(2))*pyr(0)),-kflf(1))

      IF(nfet.LE.2) kflf(3)=0

      IF(kflf(3).NE.0) THEN

        kflfc=isign(1000*max(iabs(kflf(1)),iabs(kflf(3)))+

     &  100*min(iabs(kflf(1)),iabs(kflf(3)))+1,kflf(1))

        IF(kflf(1).EQ.kflf(3).OR.(1d0+3d0*parj(4))*pyr(0).GT.1d0)

     &  kflfc=kflfc+isign(2,kflfc)

      ELSE

        kflfc=kflf(1)

      ENDIF

      CALL pykfdi(kflfc,kflf(2),kfldmp,kf)

      IF(kf.EQ.0) goto 280

      DO 300 j=1,max(2,nfet)

        nfl(iabs(kflf(j)))=nfl(iabs(kflf(j)))-isign(1,kflf(j))

  300 CONTINUE


C...Store hadron at random among free positions.

      npos=min(1+int(pyr(0)*nrem),nrem)

      DO 310 i=nsav+njet+1,n

        IF(k(i,1).EQ.7) npos=npos-1

        IF(k(i,1).EQ.1.OR.npos.NE.0) goto 310

        k(i,1)=1

        k(i,2)=kf

        p(i,5)=pymass(k(i,2))

        p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)

  310 CONTINUE

      nrem=nrem-1

      nreq=(iabs(nfl(1))+iabs(nfl(2))+iabs(nfl(3))-iabs(nfl(1)+

     &nfl(2)+nfl(3)))/2+iabs(nfl(1)+nfl(2)+nfl(3))/3

      IF(nrem.GT.0) goto 280


C...Compensate for missing momentum in global scheme (3 options).

  320 IF(mod(mstj(3),5).NE.0.AND.mod(mstj(3),5).NE.4) THEN

        DO 340 j=1,3

          psi(j)=0d0

          DO 330 i=nsav+njet+1,n

            psi(j)=psi(j)+p(i,j)

  330     CONTINUE

  340   CONTINUE

        psi(4)=psi(1)**2+psi(2)**2+psi(3)**2

        pws=0d0

        DO 350 i=nsav+njet+1,n

          IF(mod(mstj(3),5).EQ.1) pws=pws+p(i,4)

          IF(mod(mstj(3),5).EQ.2) pws=pws+sqrt(p(i,5)**2+(psi(1)*p(i,1)+

     &    psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))

          IF(mod(mstj(3),5).EQ.3) pws=pws+1d0

  350   CONTINUE

        DO 370 i=nsav+njet+1,n

          IF(mod(mstj(3),5).EQ.1) pw=p(i,4)

          IF(mod(mstj(3),5).EQ.2) pw=sqrt(p(i,5)**2+(psi(1)*p(i,1)+

     &    psi(2)*p(i,2)+psi(3)*p(i,3))**2/psi(4))

          IF(mod(mstj(3),5).EQ.3) pw=1d0

          DO 360 j=1,3

            p(i,j)=p(i,j)-psi(j)*pw/pws

  360     CONTINUE

          p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)

  370   CONTINUE


C...Compensate for missing momentum withing each jet separately.

      ELSEIF(mod(mstj(3),5).EQ.4) THEN

        DO 390 i=n+1,n+njet

          k(i,1)=0

          DO 380 j=1,5

            p(i,j)=0d0

  380     CONTINUE

  390   CONTINUE

        DO 410 i=nsav+njet+1,n

          ir1=k(i,3)

          ir2=n+ir1-nsav

          k(ir2,1)=k(ir2,1)+1

          pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/

     &    (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)

          DO 400 j=1,3

            p(ir2,j)=p(ir2,j)+p(i,j)-pls*p(ir1,j)

  400     CONTINUE

          p(ir2,4)=p(ir2,4)+p(i,4)

          p(ir2,5)=p(ir2,5)+pls

  410   CONTINUE

        pss=0d0

        DO 420 i=n+1,n+njet

          IF(k(i,1).NE.0) pss=pss+p(i,4)/(pecm*(0.8d0*p(i,5)+0.2d0))

  420   CONTINUE

        DO 440 i=nsav+njet+1,n

          ir1=k(i,3)

          ir2=n+ir1-nsav

          pls=(p(i,1)*p(ir1,1)+p(i,2)*p(ir1,2)+p(i,3)*p(ir1,3))/

     &    (p(ir1,1)**2+p(ir1,2)**2+p(ir1,3)**2)

          DO 430 j=1,3

            p(i,j)=p(i,j)-p(ir2,j)/k(ir2,1)+(1d0/(p(ir2,5)*pss)-1d0)*

     &      pls*p(ir1,j)

  430     CONTINUE

          p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)

  440   CONTINUE

      ENDIF


C...Scale momenta for energy conservation.

      IF(mod(mstj(3),5).NE.0) THEN

        pms=0d0

        pes=0d0

        pqs=0d0

        DO 450 i=nsav+njet+1,n

          pms=pms+p(i,5)

          pes=pes+p(i,4)

          pqs=pqs+p(i,5)**2/p(i,4)

  450   CONTINUE

        IF(pms.GE.pecm) goto 150

        neco=0

  460   neco=neco+1

        pfac=(pecm-pqs)/(pes-pqs)

        pes=0d0

        pqs=0d0

        DO 480 i=nsav+njet+1,n

          DO 470 j=1,3

            p(i,j)=pfac*p(i,j)

  470     CONTINUE

          p(i,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2+p(i,5)**2)

          pes=pes+p(i,4)

          pqs=pqs+p(i,5)**2/p(i,4)

  480   CONTINUE

        IF(neco.LT.10.AND.abs(pecm-pes).GT.2d-6*pecm) goto 460

      ENDIF


C...Origin of produced particles and parton daughter pointers.

  490 DO 500 i=nsav+njet+1,n

        IF(mstu(16).NE.2) k(i,3)=nsav+1

        IF(mstu(16).EQ.2) k(i,3)=k(k(i,3),3)

  500 CONTINUE

      DO 510 i=nsav+1,nsav+njet

        i1=k(i,3)

        k(i1,1)=k(i1,1)+10

        IF(mstu(16).NE.2) THEN

          k(i1,4)=nsav+1

          k(i1,5)=nsav+1

        ELSE

          k(i1,4)=k(i1,4)-njet+1

          k(i1,5)=k(i1,5)-njet+1

          IF(k(i1,5).LT.k(i1,4)) THEN

            k(i1,4)=0

            k(i1,5)=0

          ENDIF

        ENDIF

  510 CONTINUE


C...Document independent fragmentation system. Remove copy of jets.

      nsav=nsav+1

      k(nsav,1)=11

      k(nsav,2)=93

      k(nsav,3)=ip

      k(nsav,4)=nsav+1

      k(nsav,5)=n-njet+1

      DO 520 j=1,4

        p(nsav,j)=dps(j)

        v(nsav,j)=v(ip,j)

  520 CONTINUE

      p(nsav,5)=sqrt(max(0d0,dps(4)**2-dps(1)**2-dps(2)**2-dps(3)**2))

      v(nsav,5)=0d0

      DO 540 i=nsav+njet,n

        DO 530 j=1,5

          k(i-njet+1,j)=k(i,j)

          p(i-njet+1,j)=p(i,j)

          v(i-njet+1,j)=v(i,j)

  530   CONTINUE

  540 CONTINUE

      n=n-njet+1

      DO 550 iz=mstu90+1,mstu(90)

        mstu(90+iz)=mstu(90+iz)-njet+1

  550 CONTINUE


C...Boost back particle system. Set production vertices.

      IF(njet.NE.1) CALL pyrobo(nsav+1,n,0d0,0d0,dps(1)/dps(4),

     &dps(2)/dps(4),dps(3)/dps(4))

      DO 570 i=nsav+1,n

        DO 560 j=1,4

          v(i,j)=v(ip,j)

  560   CONTINUE

  570 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYDECY

C...Handles the decay of unstable particles.


      SUBROUTINE pydecy(IP)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/

C...Local arrays.

      dimension vdcy(4),kflo(4),kfl1(4),pv(10,5),rord(10),ue(3),be(3),

     &wtcor(10),ptau(4),pcmtau(4),dbetau(3)

      CHARACTER cidc*4

      DATA wtcor/2d0,5d0,15d0,60d0,250d0,1500d0,1.2d4,1.2d5,150d0,16d0/


C...Functions: momentum in two-particle decays and four-product.

      pawt(a,b,c)=sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2d0*a)

      four(i,j)=p(i,4)*p(j,4)-p(i,1)*p(j,1)-p(i,2)*p(j,2)-p(i,3)*p(j,3)


C...Initial values.

      ntry=0

      nsav=n

      kfa=iabs(k(ip,2))

      kfs=isign(1,k(ip,2))

      kc=pycomp(kfa)

      mstj(92)=0


C...Choose lifetime and determine decay vertex.

      IF(k(ip,1).EQ.5) THEN

        v(ip,5)=0d0

      ELSEIF(k(ip,1).NE.4) THEN

        v(ip,5)=-pmas(kc,4)*log(pyr(0))

      ENDIF

      DO 100 j=1,4

        vdcy(j)=v(ip,j)+v(ip,5)*p(ip,j)/p(ip,5)

  100 CONTINUE


C...Determine whether decay allowed or not.

      mout=0

      IF(mstj(22).EQ.2) THEN

        IF(pmas(kc,4).GT.parj(71)) mout=1

      ELSEIF(mstj(22).EQ.3) THEN

        IF(vdcy(1)**2+vdcy(2)**2+vdcy(3)**2.GT.parj(72)**2) mout=1

      ELSEIF(mstj(22).EQ.4) THEN

        IF(vdcy(1)**2+vdcy(2)**2.GT.parj(73)**2) mout=1

        IF(abs(vdcy(3)).GT.parj(74)) mout=1

      ENDIF

      IF(mout.EQ.1.AND.k(ip,1).NE.5) THEN

        k(ip,1)=4

        RETURN

      ENDIF


C...Interface to external tau decay library (for tau polarization).

      IF(kfa.EQ.15.AND.mstj(28).GE.1) THEN


C...Starting values for pointers and momenta.

        itau=ip

        DO 110 j=1,4

          ptau(j)=p(itau,j)

          pcmtau(j)=p(itau,j)

  110   CONTINUE


C...Iterate to find position and code of mother of tau.

        imtau=itau

  120   imtau=k(imtau,3)


        IF(imtau.EQ.0) THEN

C...If no known origin then impossible to do anything further.

          kforig=0

          iorig=0


        ELSEIF(k(imtau,2).EQ.k(itau,2)) THEN

C...If tau -> tau + gamma then add gamma energy and loop.

          IF(k(k(imtau,4),2).EQ.22) THEN

            DO 130 j=1,4

              pcmtau(j)=pcmtau(j)+p(k(imtau,4),j)

  130       CONTINUE

          ELSEIF(k(k(imtau,5),2).EQ.22) THEN

            DO 140 j=1,4

              pcmtau(j)=pcmtau(j)+p(k(imtau,5),j)

  140       CONTINUE

          ENDIF

          goto 120


        ELSEIF(iabs(k(imtau,2)).GT.100) THEN

C...If coming from weak decay of hadron then W is not stored in record,

C...but can be reconstructed by adding neutrino momentum.

          kforig=-isign(24,k(itau,2))

          iorig=0

          DO 160 ii=k(imtau,4),k(imtau,5)

            IF(k(ii,2)*isign(1,k(itau,2)).EQ.-16) THEN

              DO 150 j=1,4

                pcmtau(j)=pcmtau(j)+p(ii,j)

  150         CONTINUE

            ENDIF

  160     CONTINUE


        ELSE

C...If coming from resonance decay then find latest copy of this

C...resonance (may not completely agree).

          kforig=k(imtau,2)

          iorig=imtau

          DO 170 ii=imtau+1,ip-1

            IF(k(ii,2).EQ.kforig.AND.k(ii,3).EQ.iorig.AND.

     &      abs(p(ii,5)-p(iorig,5)).LT.1d-5*p(iorig,5)) iorig=ii

  170     CONTINUE

          DO 180 j=1,4

            pcmtau(j)=p(iorig,j)

  180     CONTINUE

        ENDIF


C...Boost tau to rest frame of production process (where known)

C...and rotate it to sit along +z axis.

        DO 190 j=1,3

          dbetau(j)=pcmtau(j)/pcmtau(4)

  190   CONTINUE

        IF(kforig.NE.0) CALL pyrobo(itau,itau,0d0,0d0,-dbetau(1),

     &  -dbetau(2),-dbetau(3))

        phitau=pyangl(p(itau,1),p(itau,2))

        CALL pyrobo(itau,itau,0d0,-phitau,0d0,0d0,0d0)

        thetau=pyangl(p(itau,3),p(itau,1))

        CALL pyrobo(itau,itau,-thetau,0d0,0d0,0d0,0d0)


C...Call tau decay routine (if meaningful) and fill extra info.

        IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN

          CALL pytaud(itau,iorig,kforig,ndecay)

          DO 200 ii=nsav+1,nsav+ndecay

            k(ii,1)=1

            k(ii,3)=ip

            k(ii,4)=0

            k(ii,5)=0

  200     CONTINUE

          n=nsav+ndecay

        ENDIF


C...Boost back decay tau and decay products.

        DO 210 j=1,4

          p(itau,j)=ptau(j)

  210   CONTINUE

        IF(kforig.NE.0.OR.mstj(28).EQ.2) THEN

          CALL pyrobo(nsav+1,n,thetau,phitau,0d0,0d0,0d0)

          IF(kforig.NE.0) CALL pyrobo(nsav+1,n,0d0,0d0,dbetau(1),

     &    dbetau(2),dbetau(3))


C...Skip past ordinary tau decay treatment.

          mmat=0

          mbst=0

          nd=0

          goto 630

        ENDIF

      ENDIF


C...B-Bbar mixing: flip sign of meson appropriately.

      mmix=0

      IF((kfa.EQ.511.OR.kfa.EQ.531).AND.mstj(26).GE.1) THEN

        xbbmix=parj(76)

        IF(kfa.EQ.531) xbbmix=parj(77)

        IF(sin(0.5d0*xbbmix*v(ip,5)/pmas(kc,4))**2.GT.pyr(0)) mmix=1

        IF(mmix.EQ.1) kfs=-kfs

      ENDIF


C...Check existence of decay channels. Particle/antiparticle rules.

      kca=kc

      IF(mdcy(kc,2).GT.0) THEN

        mdmdcy=mdme(mdcy(kc,2),2)

        IF(mdmdcy.GT.80.AND.mdmdcy.LE.90) kca=mdmdcy

      ENDIF

      IF(mdcy(kca,2).LE.0.OR.mdcy(kca,3).LE.0) THEN

        CALL pyerrm(9,'(PYDECY:) no decay channel defined')

        RETURN

      ENDIF

      IF(mod(kfa/1000,10).EQ.0.AND.kca.EQ.85) kfs=-kfs

      IF(kchg(kc,3).EQ.0) THEN

        kfsp=1

        kfsn=0

        IF(pyr(0).GT.0.5d0) kfs=-kfs

      ELSEIF(kfs.GT.0) THEN

        kfsp=1

        kfsn=0

      ELSE

        kfsp=0

        kfsn=1

      ENDIF


C...Sum branching ratios of allowed decay channels.

  220 nope=0

      brsu=0d0

      DO 230 idl=mdcy(kca,2),mdcy(kca,2)+mdcy(kca,3)-1

        IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.

     &  kfsn*mdme(idl,1).NE.3) goto 230

        IF(mdme(idl,2).GT.100) goto 230

        nope=nope+1

        brsu=brsu+brat(idl)

  230 CONTINUE

      IF(nope.EQ.0) THEN

        CALL pyerrm(2,'(PYDECY:) all decay channels closed by user')

        RETURN

      ENDIF


C...Select decay channel among allowed ones.

  240 rbr=brsu*pyr(0)

      idl=mdcy(kca,2)-1

  250 idl=idl+1

      IF(mdme(idl,1).NE.1.AND.kfsp*mdme(idl,1).NE.2.AND.

     &kfsn*mdme(idl,1).NE.3) THEN

        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250

      ELSEIF(mdme(idl,2).GT.100) THEN

        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1) goto 250

      ELSE

        idc=idl

        rbr=rbr-brat(idl)

        IF(idl.LT.mdcy(kca,2)+mdcy(kca,3)-1.AND.rbr.GT.0d0) goto 250

      ENDIF


C...Start readout of decay channel: matrix element, reset counters.

      mmat=mdme(idc,2)

  260 ntry=ntry+1

      IF(mod(ntry,200).EQ.0) THEN

        WRITE(cidc,'(I4)') idc

        CALL pyerrm(4,'(PYDECY:) caught in loop for decay channel'//

     &  cidc)

        goto 240

      ENDIF

      IF(ntry.GT.1000) THEN

        CALL pyerrm(14,'(PYDECY:) caught in infinite loop')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      i=n

      np=0

      nq=0

      mbst=0

      IF(mmat.GE.11.AND.p(ip,4).GT.20d0*p(ip,5)) mbst=1

      DO 270 j=1,4

        pv(1,j)=0d0

        IF(mbst.EQ.0) pv(1,j)=p(ip,j)

  270 CONTINUE

      IF(mbst.EQ.1) pv(1,4)=p(ip,5)

      pv(1,5)=p(ip,5)

      ps=0d0

      psq=0d0

      mrem=0

      mhaddy=0

      IF(kfa.GT.80) mhaddy=1


C...Read out decay products. Convert to standard flavour code.

      jtmax=5

      IF(mdme(idc+1,2).EQ.101) jtmax=10

      DO 280 jt=1,jtmax

        IF(jt.LE.5) kp=kfdp(idc,jt)

        IF(jt.GE.6) kp=kfdp(idc+1,jt-5)

        IF(kp.EQ.0) goto 280

        kpa=iabs(kp)

        kcp=pycomp(kpa)

        IF(kpa.GT.80) mhaddy=1

        IF(kchg(kcp,3).EQ.0.AND.kpa.NE.81.AND.kpa.NE.82) THEN

          kfp=kp

        ELSEIF(kpa.NE.81.AND.kpa.NE.82) THEN

          kfp=kfs*kp

        ELSEIF(kpa.EQ.81.AND.mod(kfa/1000,10).EQ.0) THEN

          kfp=-kfs*mod(kfa/10,10)

        ELSEIF(kpa.EQ.81.AND.mod(kfa/100,10).GE.mod(kfa/10,10)) THEN

          kfp=kfs*(100*mod(kfa/10,100)+3)

        ELSEIF(kpa.EQ.81) THEN

          kfp=kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)

        ELSEIF(kp.EQ.82) THEN

          CALL pykfdi(-kfs*int(1d0+(2d0+parj(2))*pyr(0)),0,kfp,kdump)

          IF(kfp.EQ.0) goto 260

          mstj(93)=1

          IF(pv(1,5).LT.parj(32)+2d0*pymass(kfp)) goto 260

        ELSEIF(kp.EQ.-82) THEN

          kfp=-kfp

          IF(iabs(kfp).GT.10) kfp=kfp+isign(10000,kfp)

        ENDIF

        IF(kpa.EQ.81.OR.kpa.EQ.82) kcp=pycomp(mod(kfp,10000))


C...Add decay product to event record or to quark flavour list.

        kfpa=iabs(kfp)

        kqp=kchg(kcp,2)

        IF(mmat.GE.11.AND.mmat.LE.30.AND.kqp.NE.0) THEN

          nq=nq+1

          kflo(nq)=kfp

          mstj(93)=2

          psq=psq+pymass(kflo(nq))

        ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.48).AND.np.EQ.3.AND.

     &    mod(nq,2).EQ.1) THEN

          nq=nq-1

          ps=ps-p(i,5)

          k(i,1)=1

          kfi=k(i,2)

          CALL pykfdi(kfp,kfi,kfldmp,k(i,2))

          IF(k(i,2).EQ.0) goto 260

          mstj(93)=1

          p(i,5)=pymass(k(i,2))

          ps=ps+p(i,5)

        ELSE

          i=i+1

          np=np+1

          IF(mmat.NE.33.AND.kqp.NE.0) nq=nq+1

          IF(mmat.EQ.33.AND.kqp.NE.0.AND.kqp.NE.2) nq=nq+1

          k(i,1)=1+mod(nq,2)

          IF(mmat.EQ.4.AND.jt.LE.2.AND.kfp.EQ.21) k(i,1)=2

          IF(mmat.EQ.4.AND.jt.EQ.3) k(i,1)=1

          k(i,2)=kfp

          k(i,3)=ip

          k(i,4)=0

          k(i,5)=0

          p(i,5)=pymass(kfp)

          ps=ps+p(i,5)

        ENDIF

  280 CONTINUE


C...Check masses for resonance decays.

      IF(mhaddy.EQ.0) THEN

        IF(ps+parj(64).GT.pv(1,5)) goto 240

      ENDIF


C...Choose decay multiplicity in phase space model.

  290 IF(mmat.GE.11.AND.mmat.LE.30) THEN

        psp=ps

        cnde=parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1d0))

        IF(mmat.EQ.12) cnde=cnde+parj(63)

  300   ntry=ntry+1

        IF(ntry.GT.1000) THEN

          CALL pyerrm(14,'(PYDECY:) caught in infinite loop')

          IF(mstu(21).GE.1) RETURN

        ENDIF

        IF(mmat.LE.20) THEN

          gauss=sqrt(-2d0*cnde*log(max(1d-10,pyr(0))))*

     &    sin(paru(2)*pyr(0))

          nd=0.5d0+0.5d0*np+0.25d0*nq+cnde+gauss

          IF(nd.LT.np+nq/2.OR.nd.LT.2.OR.nd.GT.10) goto 300

          IF(mmat.EQ.13.AND.nd.EQ.2) goto 300

          IF(mmat.EQ.14.AND.nd.LE.3) goto 300

          IF(mmat.EQ.15.AND.nd.LE.4) goto 300

        ELSE

          nd=mmat-20

        ENDIF


C...Form hadrons from flavour content.

        DO 310 jt=1,4

          kfl1(jt)=kflo(jt)

  310   CONTINUE

        IF(nd.EQ.np+nq/2) goto 330

        DO 320 i=n+np+1,n+nd-nq/2

          jt=1+int((nq-1)*pyr(0))

          CALL pykfdi(kfl1(jt),0,kfl2,k(i,2))

          IF(k(i,2).EQ.0) goto 300

          kfl1(jt)=-kfl2

  320   CONTINUE

  330   jt=2

        jt2=3

        jt3=4

        IF(nq.EQ.4.AND.pyr(0).LT.parj(66)) jt=4

        IF(jt.EQ.4.AND.isign(1,kfl1(1)*(10-iabs(kfl1(1))))*

     &  isign(1,kfl1(jt)*(10-iabs(kfl1(jt)))).GT.0) jt=3

        IF(jt.EQ.3) jt2=2

        IF(jt.EQ.4) jt3=2

        CALL pykfdi(kfl1(1),kfl1(jt),kfldmp,k(n+nd-nq/2+1,2))

        IF(k(n+nd-nq/2+1,2).EQ.0) goto 300

        IF(nq.EQ.4) CALL pykfdi(kfl1(jt2),kfl1(jt3),kfldmp,k(n+nd,2))

        IF(nq.EQ.4.AND.k(n+nd,2).EQ.0) goto 300


C...Check that sum of decay product masses not too large.

        ps=psp

        DO 340 i=n+np+1,n+nd

          k(i,1)=1

          k(i,3)=ip

          k(i,4)=0

          k(i,5)=0

          p(i,5)=pymass(k(i,2))

          ps=ps+p(i,5)

  340   CONTINUE

        IF(ps+parj(64).GT.pv(1,5)) goto 300


C...Rescale energy to subtract off spectator quark mass.

      ELSEIF((mmat.EQ.31.OR.mmat.EQ.33.OR.mmat.EQ.44)

     &  .AND.np.GE.3) THEN

        ps=ps-p(n+np,5)

        pqt=(p(n+np,5)+parj(65))/pv(1,5)

        DO 350 j=1,5

          p(n+np,j)=pqt*pv(1,j)

          pv(1,j)=(1d0-pqt)*pv(1,j)

  350   CONTINUE

        IF(ps+parj(64).GT.pv(1,5)) goto 260

        nd=np-1

        mrem=1


C...Fully specified final state: check mass broadening effects.

      ELSE

        IF(np.GE.2.AND.ps+parj(64).GT.pv(1,5)) goto 260

        nd=np

      ENDIF


C...Determine position of grandmother, number of sisters.

      nm=0

      kfas=0

      msgn=0

      IF(mmat.EQ.3) THEN

        im=k(ip,3)

        IF(im.LT.0.OR.im.GE.ip) im=0

        IF(im.NE.0) kfam=iabs(k(im,2))

        IF(im.NE.0) THEN

          DO 360 il=max(ip-2,im+1),min(ip+2,n)

            IF(k(il,3).EQ.im) nm=nm+1

            IF(k(il,3).EQ.im.AND.il.NE.ip) isis=il

  360     CONTINUE

          IF(nm.NE.2.OR.kfam.LE.100.OR.mod(kfam,10).NE.1.OR.

     &    mod(kfam/1000,10).NE.0) nm=0

          IF(nm.EQ.2) THEN

            kfas=iabs(k(isis,2))

            IF((kfas.LE.100.OR.mod(kfas,10).NE.1.OR.

     &      mod(kfas/1000,10).NE.0).AND.kfas.NE.22) nm=0

          ENDIF

        ENDIF

      ENDIF


C...Kinematics of one-particle decays.

      IF(nd.EQ.1) THEN

        DO 370 j=1,4

          p(n+1,j)=p(ip,j)

  370   CONTINUE

        goto 630

      ENDIF


C...Calculate maximum weight ND-particle decay.

      pv(nd,5)=p(n+nd,5)

      IF(nd.GE.3) THEN

        wtmax=1d0/wtcor(nd-2)

        pmax=pv(1,5)-ps+p(n+nd,5)

        pmin=0d0

        DO 380 il=nd-1,1,-1

          pmax=pmax+p(n+il,5)

          pmin=pmin+p(n+il+1,5)

          wtmax=wtmax*pawt(pmax,pmin,p(n+il,5))

  380   CONTINUE

      ENDIF


C...Find virtual gamma mass in Dalitz decay.

  390 IF(nd.EQ.2) THEN

      ELSEIF(mmat.EQ.2) THEN

        pmes=4d0*pmas(11,1)**2

        pmrho2=pmas(131,1)**2

        pgrho2=pmas(131,2)**2

  400   pmst=pmes*(p(ip,5)**2/pmes)**pyr(0)

        wt=(1+0.5d0*pmes/pmst)*sqrt(max(0d0,1d0-pmes/pmst))*

     &  (1d0-pmst/p(ip,5)**2)**3*(1d0+pgrho2/pmrho2)/

     &  ((1d0-pmst/pmrho2)**2+pgrho2/pmrho2)

        IF(wt.LT.pyr(0)) goto 400

        pv(2,5)=max(2.00001d0*pmas(11,1),sqrt(pmst))


C...M-generator gives weight. If rejected, try again.

      ELSE

  410   rord(1)=1d0

        DO 440 il1=2,nd-1

          rsav=pyr(0)

          DO 420 il2=il1-1,1,-1

            IF(rsav.LE.rord(il2)) goto 430

            rord(il2+1)=rord(il2)

  420     CONTINUE

  430     rord(il2+1)=rsav

  440   CONTINUE

        rord(nd)=0d0

        wt=1d0

        DO 450 il=nd-1,1,-1

          pv(il,5)=pv(il+1,5)+p(n+il,5)+(rord(il)-rord(il+1))*

     &    (pv(1,5)-ps)

          wt=wt*pawt(pv(il,5),pv(il+1,5),p(n+il,5))

  450   CONTINUE

        IF(wt.LT.pyr(0)*wtmax) goto 410

      ENDIF


C...Perform two-particle decays in respective CM frame.

  460 DO 480 il=1,nd-1

        pa=pawt(pv(il,5),pv(il+1,5),p(n+il,5))

        ue(3)=2d0*pyr(0)-1d0

        phi=paru(2)*pyr(0)

        ue(1)=sqrt(1d0-ue(3)**2)*cos(phi)

        ue(2)=sqrt(1d0-ue(3)**2)*sin(phi)

        DO 470 j=1,3

          p(n+il,j)=pa*ue(j)

          pv(il+1,j)=-pa*ue(j)

  470   CONTINUE

        p(n+il,4)=sqrt(pa**2+p(n+il,5)**2)

        pv(il+1,4)=sqrt(pa**2+pv(il+1,5)**2)

  480 CONTINUE


C...Lorentz transform decay products to lab frame.

      DO 490 j=1,4

        p(n+nd,j)=pv(nd,j)

  490 CONTINUE

      DO 530 il=nd-1,1,-1

        DO 500 j=1,3

          be(j)=pv(il,j)/pv(il,4)

  500   CONTINUE

        ga=pv(il,4)/pv(il,5)

        DO 520 i=n+il,n+nd

          bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)

          DO 510 j=1,3

            p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)

  510     CONTINUE

          p(i,4)=ga*(p(i,4)+bep)

  520   CONTINUE

  530 CONTINUE


C...Check that no infinite loop in matrix element weight.

      ntry=ntry+1

      IF(ntry.GT.800) goto 560


C...Matrix elements for omega and phi decays.

      IF(mmat.EQ.1) THEN

        wt=(p(n+1,5)*p(n+2,5)*p(n+3,5))**2-(p(n+1,5)*four(n+2,n+3))**2

     &  -(p(n+2,5)*four(n+1,n+3))**2-(p(n+3,5)*four(n+1,n+2))**2

     &  +2d0*four(n+1,n+2)*four(n+1,n+3)*four(n+2,n+3)

        IF(max(wt*wtcor(9)/p(ip,5)**6,0.001d0).LT.pyr(0)) goto 390


C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.

      ELSEIF(mmat.EQ.2) THEN

        four12=four(n+1,n+2)

        four13=four(n+1,n+3)

        wt=(pmst-0.5d0*pmes)*(four12**2+four13**2)+

     &  pmes*(four12*four13+four12**2+four13**2)

        IF(wt.LT.pyr(0)*0.25d0*pmst*(p(ip,5)**2-pmst)**2) goto 460


C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,

C...V vector), of form cos**2(theta02) in V1 rest frame, and for

C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).

      ELSEIF(mmat.EQ.3.AND.nm.EQ.2) THEN

        four10=four(ip,im)

        four12=four(ip,n+1)

        four02=four(im,n+1)

        pms1=p(ip,5)**2

        pms0=p(im,5)**2

        pms2=p(n+1,5)**2

        IF(kfas.NE.22) hnum=(four10*four12-pms1*four02)**2

        IF(kfas.EQ.22) hnum=pms1*(2d0*four10*four12*four02-

     &  pms1*four02**2-pms0*four12**2-pms2*four10**2+pms1*pms0*pms2)

        hnum=max(1d-6*pms1**2*pms0*pms2,hnum)

        hden=(four10**2-pms1*pms0)*(four12**2-pms1*pms2)

        IF(hnum.LT.pyr(0)*hden) goto 460


C...Matrix element for "onium" -> g + g + g or gamma + g + g.

      ELSEIF(mmat.EQ.4) THEN

        hx1=2d0*four(ip,n+1)/p(ip,5)**2

        hx2=2d0*four(ip,n+2)/p(ip,5)**2

        hx3=2d0*four(ip,n+3)/p(ip,5)**2

        wt=((1d0-hx1)/(hx2*hx3))**2+((1d0-hx2)/(hx1*hx3))**2+

     &  ((1d0-hx3)/(hx1*hx2))**2

        IF(wt.LT.2d0*pyr(0)) goto 390

        IF(k(ip+1,2).EQ.22.AND.(1d0-hx1)*p(ip,5)**2.LT.4d0*parj(32)**2)

     &  goto 390


C...Effective matrix element for nu spectrum in tau -> nu + hadrons.

      ELSEIF(mmat.EQ.41) THEN

        hx1=2d0*four(ip,n+1)/p(ip,5)**2

        hxm=min(0.75d0,2d0*(1d0-ps/p(ip,5)))

        IF(hx1*(3d0-2d0*hx1).LT.pyr(0)*hxm*(3d0-2d0*hxm)) goto 390


C...Matrix elements for weak decays (only semileptonic for c and b)

      ELSEIF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)

     &  .AND.nd.EQ.3) THEN

        IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+3)

        IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+3)

        IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390

      ELSEIF(mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48) THEN

        DO 550 j=1,4

          p(n+np+1,j)=0d0

          DO 540 is=n+3,n+np

            p(n+np+1,j)=p(n+np+1,j)+p(is,j)

  540     CONTINUE

  550   CONTINUE

        IF(mbst.EQ.0) wt=four(ip,n+1)*four(n+2,n+np+1)

        IF(mbst.EQ.1) wt=p(ip,5)*p(n+1,4)*four(n+2,n+np+1)

        IF(wt.LT.pyr(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) goto 390

      ENDIF


C...Scale back energy and reattach spectator.

  560 IF(mrem.EQ.1) THEN

        DO 570 j=1,5

          pv(1,j)=pv(1,j)/(1d0-pqt)

  570   CONTINUE

        nd=nd+1

        mrem=0

      ENDIF


C...Low invariant mass for system with spectator quark gives particle,

C...not two jets. Readjust momenta accordingly.

      IF(mmat.EQ.31.AND.nd.EQ.3) THEN

        mstj(93)=1

        pm2=pymass(k(n+2,2))

        mstj(93)=1

        pm3=pymass(k(n+3,2))

        IF(p(n+2,5)**2+p(n+3,5)**2+2d0*four(n+2,n+3).GE.

     &  (parj(32)+pm2+pm3)**2) goto 630

        k(n+2,1)=1

        kftemp=k(n+2,2)

        CALL pykfdi(kftemp,k(n+3,2),kfldmp,k(n+2,2))

        IF(k(n+2,2).EQ.0) goto 260

        p(n+2,5)=pymass(k(n+2,2))

        ps=p(n+1,5)+p(n+2,5)

        pv(2,5)=p(n+2,5)

        mmat=0

        nd=2

        goto 460

      ELSEIF(mmat.EQ.44) THEN

        mstj(93)=1

        pm3=pymass(k(n+3,2))

        mstj(93)=1

        pm4=pymass(k(n+4,2))

        IF(p(n+3,5)**2+p(n+4,5)**2+2d0*four(n+3,n+4).GE.

     &  (parj(32)+pm3+pm4)**2) goto 600

        k(n+3,1)=1

        kftemp=k(n+3,2)

        CALL pykfdi(kftemp,k(n+4,2),kfldmp,k(n+3,2))

        IF(k(n+3,2).EQ.0) goto 260

        p(n+3,5)=pymass(k(n+3,2))

        DO 580 j=1,3

          p(n+3,j)=p(n+3,j)+p(n+4,j)

  580   CONTINUE

        p(n+3,4)=sqrt(p(n+3,1)**2+p(n+3,2)**2+p(n+3,3)**2+p(n+3,5)**2)

        ha=p(n+1,4)**2-p(n+2,4)**2

        hb=ha-(p(n+1,5)**2-p(n+2,5)**2)

        hc=(p(n+1,1)-p(n+2,1))**2+(p(n+1,2)-p(n+2,2))**2+

     &  (p(n+1,3)-p(n+2,3))**2

        hd=(pv(1,4)-p(n+3,4))**2

        he=ha**2-2d0*hd*(p(n+1,4)**2+p(n+2,4)**2)+hd**2

        hf=hd*hc-hb**2

        hg=hd*hc-ha*hb

        hh=(sqrt(hg**2+he*hf)-hg)/(2d0*hf)

        DO 590 j=1,3

          pcor=hh*(p(n+1,j)-p(n+2,j))

          p(n+1,j)=p(n+1,j)+pcor

          p(n+2,j)=p(n+2,j)-pcor

  590   CONTINUE

        p(n+1,4)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2+p(n+1,5)**2)

        p(n+2,4)=sqrt(p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2+p(n+2,5)**2)

        nd=nd-1

      ENDIF


C...Check invariant mass of W jets. May give one particle or start over.

  600 IF((mmat.EQ.42.OR.mmat.EQ.43.OR.mmat.EQ.44.OR.mmat.EQ.48)

     &.AND.iabs(k(n+1,2)).LT.10) THEN

        pmr=sqrt(max(0d0,p(n+1,5)**2+p(n+2,5)**2+2d0*four(n+1,n+2)))

        mstj(93)=1

        pm1=pymass(k(n+1,2))

        mstj(93)=1

        pm2=pymass(k(n+2,2))

        IF(pmr.GT.parj(32)+pm1+pm2) goto 610

        kfldum=int(1.5d0+pyr(0))

        CALL pykfdi(k(n+1,2),-isign(kfldum,k(n+1,2)),kfldmp,kf1)

        CALL pykfdi(k(n+2,2),-isign(kfldum,k(n+2,2)),kfldmp,kf2)

        IF(kf1.EQ.0.OR.kf2.EQ.0) goto 260

        psm=pymass(kf1)+pymass(kf2)

        IF((mmat.EQ.42.OR.mmat.EQ.48).AND.pmr.GT.parj(64)+psm) goto 610

        IF(mmat.GE.43.AND.pmr.GT.0.2d0*parj(32)+psm) goto 610

        IF(mmat.EQ.48) goto 390

        IF(nd.EQ.4.OR.kfa.EQ.15) goto 260

        k(n+1,1)=1

        kftemp=k(n+1,2)

        CALL pykfdi(kftemp,k(n+2,2),kfldmp,k(n+1,2))

        IF(k(n+1,2).EQ.0) goto 260

        p(n+1,5)=pymass(k(n+1,2))

        k(n+2,2)=k(n+3,2)

        p(n+2,5)=p(n+3,5)

        ps=p(n+1,5)+p(n+2,5)

        IF(ps+parj(64).GT.pv(1,5)) goto 260

        pv(2,5)=p(n+3,5)

        mmat=0

        nd=2

        goto 460

      ENDIF


C...Phase space decay of partons from W decay.

  610 IF((mmat.EQ.42.OR.mmat.EQ.48).AND.iabs(k(n+1,2)).LT.10) THEN

        kflo(1)=k(n+1,2)

        kflo(2)=k(n+2,2)

        k(n+1,1)=k(n+3,1)

        k(n+1,2)=k(n+3,2)

        DO 620 j=1,5

          pv(1,j)=p(n+1,j)+p(n+2,j)

          p(n+1,j)=p(n+3,j)

  620   CONTINUE

        pv(1,5)=pmr

        n=n+1

        np=0

        nq=2

        ps=0d0

        mstj(93)=2

        psq=pymass(kflo(1))

        mstj(93)=2

        psq=psq+pymass(kflo(2))

        mmat=11

        goto 290

      ENDIF


C...Boost back for rapidly moving particle.

  630 n=n+nd

      IF(mbst.EQ.1) THEN

        DO 640 j=1,3

          be(j)=p(ip,j)/p(ip,4)

  640   CONTINUE

        ga=p(ip,4)/p(ip,5)

        DO 660 i=nsav+1,n

          bep=be(1)*p(i,1)+be(2)*p(i,2)+be(3)*p(i,3)

          DO 650 j=1,3

            p(i,j)=p(i,j)+ga*(ga*bep/(1d0+ga)+p(i,4))*be(j)

  650     CONTINUE

          p(i,4)=ga*(p(i,4)+bep)

  660   CONTINUE

      ENDIF


C...Fill in position of decay vertex.

      DO 680 i=nsav+1,n

        DO 670 j=1,4

          v(i,j)=vdcy(j)

  670   CONTINUE

        v(i,5)=0d0

  680 CONTINUE


C...Set up for parton shower evolution from jets.

      IF(mstj(23).GE.1.AND.mmat.EQ.4.AND.k(nsav+1,2).EQ.21) THEN

        k(nsav+1,1)=3

        k(nsav+2,1)=3

        k(nsav+3,1)=3

        k(nsav+1,4)=mstu(5)*(nsav+2)

        k(nsav+1,5)=mstu(5)*(nsav+3)

        k(nsav+2,4)=mstu(5)*(nsav+3)

        k(nsav+2,5)=mstu(5)*(nsav+1)

        k(nsav+3,4)=mstu(5)*(nsav+1)

        k(nsav+3,5)=mstu(5)*(nsav+2)

        mstj(92)=-(nsav+1)

      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.4) THEN

        k(nsav+2,1)=3

        k(nsav+3,1)=3

        k(nsav+2,4)=mstu(5)*(nsav+3)

        k(nsav+2,5)=mstu(5)*(nsav+3)

        k(nsav+3,4)=mstu(5)*(nsav+2)

        k(nsav+3,5)=mstu(5)*(nsav+2)

        mstj(92)=nsav+2

      ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.

     &  iabs(k(nsav+1,2)).LE.10.AND.iabs(k(nsav+2,2)).LE.10) THEN

        k(nsav+1,1)=3

        k(nsav+2,1)=3

        k(nsav+1,4)=mstu(5)*(nsav+2)

        k(nsav+1,5)=mstu(5)*(nsav+2)

        k(nsav+2,4)=mstu(5)*(nsav+1)

        k(nsav+2,5)=mstu(5)*(nsav+1)

        mstj(92)=nsav+1

      ELSEIF(mstj(23).GE.1.AND.(mmat.EQ.32.OR.mmat.EQ.44).AND.

     &  iabs(k(nsav+1,2)).LE.20.AND.iabs(k(nsav+2,2)).LE.20) THEN

        mstj(92)=nsav+1

      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33.AND.iabs(k(nsav+2,2)).EQ.21)

     &  THEN

        k(nsav+1,1)=3

        k(nsav+2,1)=3

        k(nsav+3,1)=3

        kcp=pycomp(k(nsav+1,2))

        kqp=kchg(kcp,2)*isign(1,k(nsav+1,2))

        jcon=4

        IF(kqp.LT.0) jcon=5

        k(nsav+1,jcon)=mstu(5)*(nsav+2)

        k(nsav+2,9-jcon)=mstu(5)*(nsav+1)

        k(nsav+2,jcon)=mstu(5)*(nsav+3)

        k(nsav+3,9-jcon)=mstu(5)*(nsav+2)

        mstj(92)=nsav+1

      ELSEIF(mstj(23).GE.1.AND.mmat.EQ.33) THEN

        k(nsav+1,1)=3

        k(nsav+3,1)=3

        k(nsav+1,4)=mstu(5)*(nsav+3)

        k(nsav+1,5)=mstu(5)*(nsav+3)

        k(nsav+3,4)=mstu(5)*(nsav+1)

        k(nsav+3,5)=mstu(5)*(nsav+1)

        mstj(92)=nsav+1

      ENDIF


C...Mark decayed particle; special option for B-Bbar mixing.

      IF(k(ip,1).EQ.5) k(ip,1)=15

      IF(k(ip,1).LE.10) k(ip,1)=11

      IF(mmix.EQ.1.AND.mstj(26).EQ.2.AND.k(ip,1).EQ.11) k(ip,1)=12

      k(ip,4)=nsav+1

      k(ip,5)=n


      RETURN

      END


C*********************************************************************


C...PYKFDI

C...Generates a new flavour pair and combines off a hadron.


      SUBROUTINE pykfdi(KFL1,KFL2,KFL3,KF)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Default flavour values. Input consistency checks.

      kf1a=iabs(kfl1)

      kf2a=iabs(kfl2)

      kfl3=0

      kf=0

      IF(kf1a.EQ.0) RETURN

      IF(kf2a.NE.0) THEN

        IF(kf1a.LE.10.AND.kf2a.LE.10.AND.kfl1*kfl2.GT.0) RETURN

        IF(kf1a.GT.10.AND.kf2a.GT.10) RETURN

        IF((kf1a.GT.10.OR.kf2a.GT.10).AND.kfl1*kfl2.LT.0) RETURN

      ENDIF


C...Check if tabulated flavour probabilities are to be used.

      IF(mstj(15).EQ.1) THEN

        ktab1=-1

        IF(kf1a.GE.1.AND.kf1a.LE.6) ktab1=kf1a

        kfl1a=mod(kf1a/1000,10)

        kfl1b=mod(kf1a/100,10)

        kfl1s=mod(kf1a,10)

        IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1b.GE.1.AND.kfl1b.LE.4)

     &  ktab1=6+kfl1a*(kfl1a-2)+2*kfl1b+(kfl1s-1)/2

        IF(kfl1a.GE.1.AND.kfl1a.LE.4.AND.kfl1a.EQ.kfl1b) ktab1=ktab1-1

        IF(kf1a.GE.1.AND.kf1a.LE.6) kfl1a=kf1a

        ktab2=0

        IF(kf2a.NE.0) THEN

          ktab2=-1

          IF(kf2a.GE.1.AND.kf2a.LE.6) ktab2=kf2a

          kfl2a=mod(kf2a/1000,10)

          kfl2b=mod(kf2a/100,10)

          kfl2s=mod(kf2a,10)

          IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2b.GE.1.AND.kfl2b.LE.4)

     &    ktab2=6+kfl2a*(kfl2a-2)+2*kfl2b+(kfl2s-1)/2

          IF(kfl2a.GE.1.AND.kfl2a.LE.4.AND.kfl2a.EQ.kfl2b) ktab2=ktab2-1

        ENDIF

        IF(ktab1.GE.0.AND.ktab2.GE.0) goto 150

      ENDIF


C...Parameters and breaking diquark parameter combinations.

  100 par2=parj(2)

      par3=parj(3)

      par4=3d0*parj(4)

      IF(mstj(12).GE.2) THEN

        par3m=sqrt(parj(3))

        par4m=1d0/(3d0*sqrt(parj(4)))

        pardm=parj(7)/(parj(7)+par3m*parj(6))

        pars0=parj(5)*(2d0+(1d0+par2*par3m*parj(7))*(1d0+par4m))

        pars1=parj(7)*pars0/(2d0*par3m)+parj(5)*(parj(6)*(1d0+par4m)+

     &  par2*par3m*parj(6)*parj(7))

        pars2=parj(5)*2d0*parj(6)*parj(7)*(par2*parj(7)+

     &  (1d0+par4m)/par3m)

        parsm=max(pars0,pars1,pars2)

        par4=par4*(1d0+parsm)/(1d0+parsm/(3d0*par4m))

      ENDIF


C...Choice of whether to generate meson or baryon.

  110 mbary=0

      kfda=0

      IF(kf1a.LE.10) THEN

        IF(kf2a.EQ.0.AND.mstj(12).GE.1.AND.(1d0+parj(1))*pyr(0).GT.1d0)

     &  mbary=1

        IF(kf2a.GT.10) mbary=2

        IF(kf2a.GT.10.AND.kf2a.LE.10000) kfda=kf2a

      ELSE

        mbary=2

        IF(kf1a.LE.10000) kfda=kf1a

      ENDIF


C...Possibility of process diquark -> meson + new diquark.

      IF(kfda.NE.0.AND.mstj(12).GE.2) THEN

        kflda=mod(kfda/1000,10)

        kfldb=mod(kfda/100,10)

        kflds=mod(kfda,10)

        wtdq=pars0

        IF(max(kflda,kfldb).EQ.3) wtdq=pars1

        IF(min(kflda,kfldb).EQ.3) wtdq=pars2

        IF(kflds.EQ.1) wtdq=wtdq/(3d0*par4m)

        IF((1d0+wtdq)*pyr(0).GT.1d0) mbary=-1

        IF(mbary.EQ.-1.AND.kf2a.NE.0) RETURN

      ENDIF


C...Flavour for meson, possibly with new flavour.

      IF(mbary.LE.0) THEN

        kfs=isign(1,kfl1)

        IF(mbary.EQ.0) THEN

          IF(kf2a.EQ.0) kfl3=isign(1+int((2d0+par2)*pyr(0)),-kfl1)

          kfla=max(kf1a,kf2a+iabs(kfl3))

          kflb=min(kf1a,kf2a+iabs(kfl3))

          IF(kfla.NE.kf1a) kfs=-kfs


C...Splitting of diquark into meson plus new diquark.

        ELSE

          kfl1a=mod(kf1a/1000,10)

          kfl1b=mod(kf1a/100,10)

  120     kfl1d=kfl1a+int(pyr(0)+0.5d0)*(kfl1b-kfl1a)

          kfl1e=kfl1a+kfl1b-kfl1d

          IF((kfl1d.EQ.3.AND.pyr(0).GT.pardm).OR.(kfl1e.EQ.3.AND.

     &    pyr(0).LT.pardm)) THEN

            kfl1d=kfl1a+kfl1b-kfl1d

            kfl1e=kfl1a+kfl1b-kfl1e

          ENDIF

          kfl3a=1+int((2d0+par2*par3m*parj(7))*pyr(0))

          IF((kfl1e.NE.kfl3a.AND.pyr(0).GT.(1d0+par4m)/

     &    max(2d0,1d0+par4m)).OR.(kfl1e.EQ.kfl3a.AND.pyr(0).GT.

     &    2d0/max(2d0,1d0+par4m))) goto 120

          kflds=3

          IF(kfl1e.NE.kfl3a) kflds=2*int(pyr(0)+1d0/(1d0+par4m))+1

          kfl3=isign(10000+1000*max(kfl1e,kfl3a)+100*min(kfl1e,kfl3a)+

     &    kflds,-kfl1)

          kfla=max(kfl1d,kfl3a)

          kflb=min(kfl1d,kfl3a)

          IF(kfla.NE.kfl1d) kfs=-kfs

        ENDIF


C...Form meson, with spin and flavour mixing for diagonal states.

        IF(kfla.LE.2) kmul=int(parj(11)+pyr(0))

        IF(kfla.EQ.3) kmul=int(parj(12)+pyr(0))

        IF(kfla.GE.4) kmul=int(parj(13)+pyr(0))

        IF(kmul.EQ.0.AND.parj(14).GT.0d0) THEN

          IF(pyr(0).LT.parj(14)) kmul=2

        ELSEIF(kmul.EQ.1.AND.parj(15)+parj(16)+parj(17).GT.0d0) THEN

          rmul=pyr(0)

          IF(rmul.LT.parj(15)) kmul=3

          IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)) kmul=4

          IF(kmul.EQ.1.AND.rmul.LT.parj(15)+parj(16)+parj(17)) kmul=5

        ENDIF

        kfls=3

        IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1

        IF(kmul.EQ.5) kfls=5

        IF(kfla.NE.kflb) THEN

          kf=(100*kfla+10*kflb+kfls)*kfs*(-1)**kfla

        ELSE

          rmix=pyr(0)

          imix=2*kfla+10*kmul

          IF(kfla.LE.3) kf=110*(1+int(rmix+parf(imix-1))+

     &    int(rmix+parf(imix)))+kfls

          IF(kfla.GE.4) kf=110*kfla+kfls

        ENDIF

        IF(kmul.EQ.2.OR.kmul.EQ.3) kf=kf+isign(10000,kf)

        IF(kmul.EQ.4) kf=kf+isign(20000,kf)


C...Optional extra suppression of eta and eta'.

        IF(kf.EQ.221) THEN

          IF(pyr(0).GT.parj(25)) goto 110

        ELSEIF(kf.EQ.331) THEN

          IF(pyr(0).GT.parj(26)) goto 110

        ENDIF


C...Generate diquark flavour.

      ELSE

  130   IF(kf1a.LE.10.AND.kf2a.EQ.0) THEN

          kfla=kf1a

  140     kflb=1+int((2d0+par2*par3)*pyr(0))

          kflc=1+int((2d0+par2*par3)*pyr(0))

          kflds=1

          IF(kflb.GE.kflc) kflds=3

          IF(kflds.EQ.1.AND.par4*pyr(0).GT.1d0) goto 140

          IF(kflds.EQ.3.AND.par4.LT.pyr(0)) goto 140

          kfl3=isign(1000*max(kflb,kflc)+100*min(kflb,kflc)+kflds,kfl1)


C...Take diquark flavour from input.

        ELSEIF(kf1a.LE.10) THEN

          kfla=kf1a

          kflb=mod(kf2a/1000,10)

          kflc=mod(kf2a/100,10)

          kflds=mod(kf2a,10)


C...Generate (or take from input) quark to go with diquark.

        ELSE

          IF(kf2a.EQ.0) kfl3=isign(1+int((2d0+par2)*pyr(0)),kfl1)

          kfla=kf2a+iabs(kfl3)

          kflb=mod(kf1a/1000,10)

          kflc=mod(kf1a/100,10)

          kflds=mod(kf1a,10)

        ENDIF


C...SU(6) factors for formation of baryon. Try again if fails.

        kbary=kflds

        IF(kflds.EQ.3.AND.kflb.NE.kflc) kbary=5

        IF(kfla.NE.kflb.AND.kfla.NE.kflc) kbary=kbary+1

        wt=parf(60+kbary)+parj(18)*parf(70+kbary)

        IF(mbary.EQ.1.AND.mstj(12).GE.2) THEN

          wtdq=pars0

          IF(max(kflb,kflc).EQ.3) wtdq=pars1

          IF(min(kflb,kflc).EQ.3) wtdq=pars2

          IF(kflds.EQ.1) wtdq=wtdq/(3d0*par4m)

          IF(kflds.EQ.1) wt=wt*(1d0+wtdq)/(1d0+parsm/(3d0*par4m))

          IF(kflds.EQ.3) wt=wt*(1d0+wtdq)/(1d0+parsm)

        ENDIF

        IF(kf2a.EQ.0.AND.wt.LT.pyr(0)) goto 130


C...Form baryon. Distinguish Lambda- and Sigmalike baryons.

        kfld=max(kfla,kflb,kflc)

        kflf=min(kfla,kflb,kflc)

        kfle=kfla+kflb+kflc-kfld-kflf

        kfls=2

        IF((parf(60+kbary)+parj(18)*parf(70+kbary))*pyr(0).GT.

     &  parf(60+kbary)) kfls=4

        kfll=0

        IF(kfls.EQ.2.AND.kfld.GT.kfle.AND.kfle.GT.kflf) THEN

          IF(kflds.EQ.1.AND.kfla.EQ.kfld) kfll=1

          IF(kflds.EQ.1.AND.kfla.NE.kfld) kfll=int(0.25d0+pyr(0))

          IF(kflds.EQ.3.AND.kfla.NE.kfld) kfll=int(0.75d0+pyr(0))

        ENDIF

        IF(kfll.EQ.0) kf=isign(1000*kfld+100*kfle+10*kflf+kfls,kfl1)

        IF(kfll.EQ.1) kf=isign(1000*kfld+100*kflf+10*kfle+kfls,kfl1)

      ENDIF

      RETURN


C...Use tabulated probabilities to select new flavour and hadron.

  150 IF(ktab2.EQ.0.AND.mstj(12).LE.0) THEN

        kt3l=1

        kt3u=6

      ELSEIF(ktab2.EQ.0.AND.ktab1.GE.7.AND.mstj(12).LE.1) THEN

        kt3l=1

        kt3u=6

      ELSEIF(ktab2.EQ.0) THEN

        kt3l=1

        kt3u=22

      ELSE

        kt3l=ktab2

        kt3u=ktab2

      ENDIF

      rfl=0d0

      DO 170 kts=0,2

        DO 160 kt3=kt3l,kt3u

          rfl=rfl+parf(120+80*ktab1+25*kts+kt3)

  160   CONTINUE

  170 CONTINUE

      rfl=pyr(0)*rfl

      DO 190 kts=0,2

        ktabs=kts

        DO 180 kt3=kt3l,kt3u

          ktab3=kt3

          rfl=rfl-parf(120+80*ktab1+25*kts+kt3)

          IF(rfl.LE.0d0) goto 200

  180   CONTINUE

  190 CONTINUE

  200 CONTINUE


C...Reconstruct flavour of produced quark/diquark.

      IF(ktab3.LE.6) THEN

        kfl3a=ktab3

        kfl3b=0

        kfl3=isign(kfl3a,kfl1*(2*ktab1-13))

      ELSE

        kfl3a=1

        IF(ktab3.GE.8) kfl3a=2

        IF(ktab3.GE.11) kfl3a=3

        IF(ktab3.GE.16) kfl3a=4

        kfl3b=(ktab3-6-kfl3a*(kfl3a-2))/2

        kfl3=1000*kfl3a+100*kfl3b+1

        IF(kfl3a.EQ.kfl3b.OR.ktab3.NE.6+kfl3a*(kfl3a-2)+2*kfl3b) kfl3=

     &  kfl3+2

        kfl3=isign(kfl3,kfl1*(13-2*ktab1))

      ENDIF


C...Reconstruct meson code.

      IF(kfl3a.EQ.kfl1a.AND.kfl3b.EQ.kfl1b.AND.(kfl3a.LE.3.OR.

     &kfl3b.NE.0)) THEN

        rfl=pyr(0)*(parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+

     &  25*ktabs)+parf(145+80*ktab1+25*ktabs))

        kf=110+2*ktabs+1

        IF(rfl.GT.parf(143+80*ktab1+25*ktabs)) kf=220+2*ktabs+1

        IF(rfl.GT.parf(143+80*ktab1+25*ktabs)+parf(144+80*ktab1+

     &  25*ktabs)) kf=330+2*ktabs+1

      ELSEIF(ktab1.LE.6.AND.ktab3.LE.6) THEN

        kfla=max(ktab1,ktab3)

        kflb=min(ktab1,ktab3)

        kfs=isign(1,kfl1)

        IF(kfla.NE.kf1a) kfs=-kfs

        kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla

      ELSEIF(ktab1.GE.7.AND.ktab3.GE.7) THEN

        kfs=isign(1,kfl1)

        IF(kfl1a.EQ.kfl3a) THEN

          kfla=max(kfl1b,kfl3b)

          kflb=min(kfl1b,kfl3b)

          IF(kfla.NE.kfl1b) kfs=-kfs

        ELSEIF(kfl1a.EQ.kfl3b) THEN

          kfla=kfl3a

          kflb=kfl1b

          kfs=-kfs

        ELSEIF(kfl1b.EQ.kfl3a) THEN

          kfla=kfl1a

          kflb=kfl3b

        ELSEIF(kfl1b.EQ.kfl3b) THEN

          kfla=max(kfl1a,kfl3a)

          kflb=min(kfl1a,kfl3a)

          IF(kfla.NE.kfl1a) kfs=-kfs

        ELSE

          CALL pyerrm(2,'(PYKFDI:) no matching flavours for qq -> qq')

          goto 100

        ENDIF

        kf=(100*kfla+10*kflb+2*ktabs+1)*kfs*(-1)**kfla


C...Reconstruct baryon code.

      ELSE

        IF(ktab1.GE.7) THEN

          kfla=kfl3a

          kflb=kfl1a

          kflc=kfl1b

        ELSE

          kfla=kfl1a

          kflb=kfl3a

          kflc=kfl3b

        ENDIF

        kfld=max(kfla,kflb,kflc)

        kflf=min(kfla,kflb,kflc)

        kfle=kfla+kflb+kflc-kfld-kflf

        IF(ktabs.EQ.0) kf=isign(1000*kfld+100*kflf+10*kfle+2,kfl1)

        IF(ktabs.GE.1) kf=isign(1000*kfld+100*kfle+10*kflf+2*ktabs,kfl1)

      ENDIF


C...Check that constructed flavour code is an allowed one.

      IF(kfl2.NE.0) kfl3=0

      kc=pycomp(kf)

      IF(kc.EQ.0) THEN

        CALL pyerrm(2,'(PYKFDI:) user-defined flavour probabilities '//

     &  'failed')

        goto 100

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYPTDI

C...Generates transverse momentum according to a Gaussian.


      SUBROUTINE pyptdi(KFL,PX,PY)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


C...Generate p_T and azimuthal angle, gives p_x and p_y.

      kfla=iabs(kfl)

      pt=parj(21)*sqrt(-log(max(1d-10,pyr(0))))

      IF(parj(23).GT.pyr(0)) pt=parj(24)*pt

      IF(mstj(91).EQ.1) pt=parj(22)*pt

      IF(kfla.EQ.0.AND.mstj(13).LE.0) pt=0d0

      phi=paru(2)*pyr(0)

      px=pt*cos(phi)

      py=pt*sin(phi)


      RETURN

      END


C*********************************************************************


C...PYZDIS

C...Generates the longitudinal splitting variable z.


      SUBROUTINE pyzdis(KFL1,KFL2,PR,Z)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Check if heavy flavour fragmentation.

      kfla=iabs(kfl1)

      kflb=iabs(kfl2)

      kflh=kfla

      IF(kfla.GE.10) kflh=mod(kfla/1000,10)


C...Lund symmetric scaling function: determine parameters of shape.

      IF(mstj(11).EQ.1.OR.(mstj(11).EQ.3.AND.kflh.LE.3).OR.

     &mstj(11).GE.4) THEN

        fa=parj(41)

        IF(mstj(91).EQ.1) fa=parj(43)

        IF(kflb.GE.10) fa=fa+parj(45)

        fbb=parj(42)

        IF(mstj(91).EQ.1) fbb=parj(44)

        fb=fbb*pr

        fc=1d0

        IF(kfla.GE.10) fc=fc-parj(45)

        IF(kflb.GE.10) fc=fc+parj(45)

        IF(mstj(11).GE.4.AND.kflh.GE.4.AND.kflh.LE.5) THEN

          fred=parj(46)

          IF(mstj(11).EQ.5.AND.kflh.EQ.5) fred=parj(47)

          fc=fc+fred*fbb*parf(100+kflh)**2

        ELSEIF(mstj(11).GE.4.AND.kflh.GE.6.AND.kflh.LE.8) THEN

          fred=parj(46)

          IF(mstj(11).EQ.5) fred=parj(48)

          fc=fc+fred*fbb*pmas(kflh,1)**2

        ENDIF

        mc=1

        IF(abs(fc-1d0).GT.0.01d0) mc=2


C...Determine position of maximum. Special cases for a = 0 or a = c.

        IF(fa.LT.0.02d0) THEN

          ma=1

          zmax=1d0

          IF(fc.GT.fb) zmax=fb/fc

        ELSEIF(abs(fc-fa).LT.0.01d0) THEN

          ma=2

          zmax=fb/(fb+fc)

        ELSE

          ma=3

          zmax=0.5d0*(fb+fc-sqrt((fb-fc)**2+4d0*fa*fb))/(fc-fa)

          IF(zmax.GT.0.9999d0.AND.fb.GT.100d0) zmax=min(zmax,1d0-fa/fb)

        ENDIF


C...Subdivide z range if distribution very peaked near endpoint.

        mmax=2

        IF(zmax.LT.0.1d0) THEN

          mmax=1

          zdiv=2.75d0*zmax

          IF(mc.EQ.1) THEN

            fint=1d0-log(zdiv)

          ELSE

            zdivc=zdiv**(1d0-fc)

            fint=1d0+(1d0-1d0/zdivc)/(fc-1d0)

          ENDIF

        ELSEIF(zmax.GT.0.85d0.AND.fb.GT.1d0) THEN

          mmax=3

          fscb=sqrt(4d0+(fc/fb)**2)

          zdiv=fscb-1d0/zmax-(fc/fb)*log(zmax*0.5d0*(fscb+fc/fb))

          IF(ma.GE.2) zdiv=zdiv+(fa/fb)*log(1d0-zmax)

          zdiv=min(zmax,max(0d0,zdiv))

          fint=1d0+fb*(1d0-zdiv)

        ENDIF


C...Choice of z, preweighted for peaks at low or high z.

  100   z=pyr(0)

        fpre=1d0

        IF(mmax.EQ.1) THEN

          IF(fint*pyr(0).LE.1d0) THEN

            z=zdiv*z

          ELSEIF(mc.EQ.1) THEN

            z=zdiv**z

            fpre=zdiv/z

          ELSE

            z=(zdivc+z*(1d0-zdivc))**(1d0/(1d0-fc))

            fpre=(zdiv/z)**fc

          ENDIF

        ELSEIF(mmax.EQ.3) THEN

          IF(fint*pyr(0).LE.1d0) THEN

            z=zdiv+log(z)/fb

            fpre=exp(fb*(z-zdiv))

          ELSE

            z=zdiv+z*(1d0-zdiv)

          ENDIF

        ENDIF


C...Weighting according to correct formula.

        IF(z.LE.0d0.OR.z.GE.1d0) goto 100

        fexp=fc*log(zmax/z)+fb*(1d0/zmax-1d0/z)

        IF(ma.GE.2) fexp=fexp+fa*log((1d0-z)/(1d0-zmax))

        fval=exp(max(-50d0,min(50d0,fexp)))

        IF(fval.LT.pyr(0)*fpre) goto 100


C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.

      ELSE

        fc=parj(50+max(1,kflh))

        IF(mstj(91).EQ.1) fc=parj(59)

  110   z=pyr(0)

        IF(fc.GE.0d0.AND.fc.LE.1d0) THEN

          IF(fc.GT.pyr(0)) z=1d0-z**(1d0/3d0)

        ELSEIF(fc.GT.-1.AND.fc.LT.0d0) THEN

          IF(-4d0*fc*z*(1d0-z)**2.LT.pyr(0)*((1d0-z)**2-fc*z)**2)

     &    goto 110

        ELSE

          IF(fc.GT.0d0) z=1d0-z**(1d0/fc)

          IF(fc.LT.0d0) z=z**(-1d0/fc)

        ENDIF

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYSHOW

C...Generates timelike parton showers from given partons.


      SUBROUTINE pyshow(IP1,IP2,QMAX)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension pmth(5,50),ps(5),pma(4),pmsd(4),iep(4),ipa(4),

     &kfla(4),kfld(4),kfl(4),itry(4),isi(4),isl(4),dp(4),dpt(5,4),

     &ksh(0:40),kcii(2),niis(2),iiis(2,2),theiis(2,2),phiiis(2,2),

     &isii(2)


C...Initialization of cutoff masses etc.

      IF(mstj(41).LE.0.OR.(mstj(41).EQ.1.AND.qmax.LE.parj(82)).OR.

     &qmax.LE.min(parj(82),parj(83))) RETURN

      DO 100 ifl=0,40

        ksh(ifl)=0

  100 CONTINUE

      ksh(21)=1

      pmth(1,21)=pymass(21)

      pmth(2,21)=sqrt(pmth(1,21)**2+0.25d0*parj(82)**2)

      pmth(3,21)=2d0*pmth(2,21)

      pmth(4,21)=pmth(3,21)

      pmth(5,21)=pmth(3,21)

      pmth(1,22)=pymass(22)

      pmth(2,22)=sqrt(pmth(1,22)**2+0.25d0*parj(83)**2)

      pmth(3,22)=2d0*pmth(2,22)

      pmth(4,22)=pmth(3,22)

      pmth(5,22)=pmth(3,22)

      pmqth1=parj(82)

      IF(mstj(41).GE.2) pmqth1=min(parj(82),parj(83))

      pmqth2=pmth(2,21)

      IF(mstj(41).GE.2) pmqth2=min(pmth(2,21),pmth(2,22))

      DO 110 ifl=1,8

        ksh(ifl)=1

        pmth(1,ifl)=pymass(ifl)

        pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*pmqth1**2)

        pmth(3,ifl)=pmth(2,ifl)+pmqth2

        pmth(4,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(82)**2)+pmth(2,21)

        pmth(5,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)+pmth(2,22)

  110 CONTINUE

      DO 120 ifl=11,17,2

        IF(mstj(41).GE.2) ksh(ifl)=1

        pmth(1,ifl)=pymass(ifl)

        pmth(2,ifl)=sqrt(pmth(1,ifl)**2+0.25d0*parj(83)**2)

        pmth(3,ifl)=pmth(2,ifl)+pmth(2,22)

        pmth(4,ifl)=pmth(3,ifl)

        pmth(5,ifl)=pmth(3,ifl)

  120 CONTINUE

      pt2min=max(0.5d0*parj(82),1.1d0*parj(81))**2

      alams=parj(81)**2

      alfm=log(pt2min/alams)


C...Store positions of shower initiating partons.

      IF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.EQ.0) THEN

        npa=1

        ipa(1)=ip1

      ELSEIF(min(ip1,ip2).GT.0.AND.max(ip1,ip2).LE.min(n,mstu(4)-

     &  mstu(32))) THEN

        npa=2

        ipa(1)=ip1

        ipa(2)=ip2

      ELSEIF(ip1.GT.0.AND.ip1.LE.min(n,mstu(4)-mstu(32)).AND.ip2.LT.0

     &  .AND.ip2.GE.-3) THEN

        npa=iabs(ip2)

        DO 130 i=1,npa

          ipa(i)=ip1+i-1

  130   CONTINUE

      ELSE

        CALL pyerrm(12,

     &  '(PYSHOW:) failed to reconstruct showering system')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Check on phase space available for emission.

      irej=0

      DO 140 j=1,5

        ps(j)=0d0

  140 CONTINUE

      pm=0d0

      DO 160 i=1,npa

        kfla(i)=iabs(k(ipa(i),2))

        pma(i)=p(ipa(i),5)

C...Special cutoff masses for t, l, h with variable masses.

        ifla=kfla(i)

        IF(kfla(i).GE.6.AND.kfla(i).LE.8) THEN

          ifla=37+kfla(i)+isign(2,k(ipa(i),2))

          pmth(1,ifla)=pma(i)

          pmth(2,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*pmqth1**2)

          pmth(3,ifla)=pmth(2,ifla)+pmqth2

          pmth(4,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(82)**2)+

     &    pmth(2,21)

          pmth(5,ifla)=sqrt(pmth(1,ifla)**2+0.25d0*parj(83)**2)+

     &    pmth(2,22)

        ENDIF

        IF(kfla(i).LE.40) THEN

          IF(ksh(kfla(i)).EQ.1) pma(i)=pmth(3,ifla)

        ENDIF

        pm=pm+pma(i)

        IF(kfla(i).GT.40) THEN

          irej=irej+1

        ELSE

          IF(ksh(kfla(i)).EQ.0.OR.pma(i).GT.qmax) irej=irej+1

        ENDIF

        DO 150 j=1,4

          ps(j)=ps(j)+p(ipa(i),j)

  150   CONTINUE

  160 CONTINUE

      IF(irej.EQ.npa) RETURN

      ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))

      IF(npa.EQ.1) ps(5)=ps(4)

      IF(ps(5).LE.pm+pmqth1) RETURN


C...Check if 3-jet matrix elements to be used.

      m3jc=0

      IF(npa.EQ.2.AND.mstj(47).GE.1) THEN

        IF(kfla(1).GE.1.AND.kfla(1).LE.8.AND.kfla(2).GE.1.AND.

     &  kfla(2).LE.8) m3jc=1

        IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.

     &  kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)) m3jc=1

        IF((kfla(1).EQ.11.OR.kfla(1).EQ.13.OR.kfla(1).EQ.15.OR.

     &  kfla(1).EQ.17).AND.kfla(2).EQ.kfla(1)+1) m3jc=1

        IF((kfla(1).EQ.12.OR.kfla(1).EQ.14.OR.kfla(1).EQ.16.OR.

     &  kfla(1).EQ.18).AND.kfla(2).EQ.kfla(1)-1) m3jc=1

        IF(mstj(47).EQ.2.OR.mstj(47).EQ.4) m3jc=1

        m3jcm=0

        IF(m3jc.EQ.1.AND.mstj(47).GE.3.AND.kfla(1).EQ.kfla(2)) THEN

          m3jcm=1

          qme=(2d0*pmth(1,kfla(1))/ps(5))**2

        ENDIF

      ENDIF


C...Find if interference with initial state partons.

      miis=0

      IF(mstj(50).GE.1.AND.mstj(50).LE.3.AND.npa.EQ.2) miis=mstj(50)

      IF(miis.NE.0) THEN

        DO 180 i=1,2

          kcii(i)=0

          kca=pycomp(kfla(i))

          IF(kca.NE.0) kcii(i)=kchg(kca,2)*isign(1,k(ipa(i),2))

          niis(i)=0

          IF(kcii(i).NE.0) THEN

            DO 170 j=1,2

              icsi=mod(k(ipa(i),3+j)/mstu(5),mstu(5))

              IF(icsi.GT.0.AND.icsi.NE.ipa(1).AND.icsi.NE.ipa(2).AND.

     &        (kcii(i).EQ.(-1)**(j+1).OR.kcii(i).EQ.2)) THEN

                niis(i)=niis(i)+1

                iiis(i,niis(i))=icsi

              ENDIF

  170       CONTINUE

          ENDIF

  180   CONTINUE

        IF(niis(1)+niis(2).EQ.0) miis=0

      ENDIF


C...Boost interfering initial partons to rest frame

C...and reconstruct their polar and azimuthal angles.

      IF(miis.NE.0) THEN

        DO 200 i=1,2

          DO 190 j=1,5

            k(n+i,j)=k(ipa(i),j)

            p(n+i,j)=p(ipa(i),j)

            v(n+i,j)=0d0

  190     CONTINUE

  200   CONTINUE

        DO 220 i=3,2+niis(1)

          DO 210 j=1,5

            k(n+i,j)=k(iiis(1,i-2),j)

            p(n+i,j)=p(iiis(1,i-2),j)

            v(n+i,j)=0d0

  210     CONTINUE

  220   CONTINUE

        DO 240 i=3+niis(1),2+niis(1)+niis(2)

          DO 230 j=1,5

            k(n+i,j)=k(iiis(2,i-2-niis(1)),j)

            p(n+i,j)=p(iiis(2,i-2-niis(1)),j)

            v(n+i,j)=0d0

  230     CONTINUE

  240   CONTINUE

        CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,0d0,-ps(1)/ps(4),

     &  -ps(2)/ps(4),-ps(3)/ps(4))

        phi=pyangl(p(n+1,1),p(n+1,2))

        CALL pyrobo(n+1,n+2+niis(1)+niis(2),0d0,-phi,0d0,0d0,0d0)

        the=pyangl(p(n+1,3),p(n+1,1))

        CALL pyrobo(n+1,n+2+niis(1)+niis(2),-the,0d0,0d0,0d0,0d0)

        DO 250 i=3,2+niis(1)

          theiis(1,i-2)=pyangl(p(n+i,3),sqrt(p(n+i,1)**2+p(n+i,2)**2))

          phiiis(1,i-2)=pyangl(p(n+i,1),p(n+i,2))

  250   CONTINUE

        DO 260 i=3+niis(1),2+niis(1)+niis(2)

          theiis(2,i-2-niis(1))=paru(1)-pyangl(p(n+i,3),

     &    sqrt(p(n+i,1)**2+p(n+i,2)**2))

          phiiis(2,i-2-niis(1))=pyangl(p(n+i,1),p(n+i,2))

  260   CONTINUE

      ENDIF


C...Define imagined single initiator of shower for parton system.

      ns=n

      IF(n.GT.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(npa.GE.2) THEN

        k(n+1,1)=11

        k(n+1,2)=21

        k(n+1,3)=0

        k(n+1,4)=0

        k(n+1,5)=0

        p(n+1,1)=0d0

        p(n+1,2)=0d0

        p(n+1,3)=0d0

        p(n+1,4)=ps(5)

        p(n+1,5)=ps(5)

        v(n+1,5)=ps(5)**2

        n=n+1

      ENDIF


C...Loop over partons that may branch.

      nep=npa

      im=ns

      IF(npa.EQ.1) im=ns-1

  270 im=im+1

      IF(n.GT.ns) THEN

        IF(im.GT.n) goto 510

        kflm=iabs(k(im,2))

        IF(kflm.GT.40) goto 270

        IF(ksh(kflm).EQ.0) goto 270

        iflm=kflm

        IF(kflm.GE.6.AND.kflm.LE.8) iflm=37+kflm+isign(2,k(im,2))

        IF(p(im,5).LT.pmth(2,iflm)) goto 270

        igm=k(im,3)

      ELSE

        igm=-1

      ENDIF

      IF(n+nep.GT.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Position of aunt (sister to branching parton).

C...Origin and flavour of daughters.

      iau=0

      IF(igm.GT.0) THEN

        IF(k(im-1,3).EQ.igm) iau=im-1

        IF(n.GE.im+1.AND.k(im+1,3).EQ.igm) iau=im+1

      ENDIF

      IF(igm.GE.0) THEN

        k(im,4)=n+1

        DO 280 i=1,nep

          k(n+i,3)=im

  280   CONTINUE

      ELSE

        k(n+1,3)=ipa(1)

      ENDIF

      IF(igm.LE.0) THEN

        DO 290 i=1,nep

          k(n+i,2)=k(ipa(i),2)

  290   CONTINUE

      ELSEIF(kflm.NE.21) THEN

        k(n+1,2)=k(im,2)

        k(n+2,2)=k(im,5)

      ELSEIF(k(im,5).EQ.21) THEN

        k(n+1,2)=21

        k(n+2,2)=21

      ELSE

        k(n+1,2)=k(im,5)

        k(n+2,2)=-k(im,5)

      ENDIF


C...Reset flags on daughers and tries made.

      DO 300 ip=1,nep

        k(n+ip,1)=3

        k(n+ip,4)=0

        k(n+ip,5)=0

        kfld(ip)=iabs(k(n+ip,2))

        IF(kchg(pycomp(kfld(ip)),2).EQ.0) k(n+ip,1)=1

        itry(ip)=0

        isl(ip)=0

        isi(ip)=0

        IF(kfld(ip).LE.40) THEN

          IF(ksh(kfld(ip)).EQ.1) isi(ip)=1

        ENDIF

  300 CONTINUE

      islm=0


C...Maximum virtuality of daughters.

      IF(igm.LE.0) THEN

        DO 310 i=1,npa

          IF(npa.GE.3) p(n+i,4)=(ps(4)*p(ipa(i),4)-ps(1)*p(ipa(i),1)-

     &    ps(2)*p(ipa(i),2)-ps(3)*p(ipa(i),3))/ps(5)

          p(n+i,5)=min(qmax,ps(5))

          IF(npa.GE.3) p(n+i,5)=min(p(n+i,5),p(n+i,4))

          IF(isi(i).EQ.0) p(n+i,5)=p(ipa(i),5)

  310   CONTINUE

      ELSE

        IF(mstj(43).LE.2) pem=v(im,2)

        IF(mstj(43).GE.3) pem=p(im,4)

        p(n+1,5)=min(p(im,5),v(im,1)*pem)

        p(n+2,5)=min(p(im,5),(1d0-v(im,1))*pem)

        IF(k(n+2,2).EQ.22) p(n+2,5)=pmth(1,22)

      ENDIF

      DO 320 i=1,nep

        pmsd(i)=p(n+i,5)

        IF(isi(i).EQ.1) THEN

          ifld=kfld(i)

          IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+

     &    isign(2,k(n+i,2))

          IF(p(n+i,5).LE.pmth(3,ifld)) p(n+i,5)=pmth(1,ifld)

        ENDIF

        v(n+i,5)=p(n+i,5)**2

  320 CONTINUE


C...Choose one of the daughters for evolution.

  330 inum=0

      IF(nep.EQ.1) inum=1

      DO 340 i=1,nep

        IF(inum.EQ.0.AND.isl(i).EQ.1) inum=i

  340 CONTINUE

      DO 350 i=1,nep

        IF(inum.EQ.0.AND.itry(i).EQ.0.AND.isi(i).EQ.1) THEN

          ifld=kfld(i)

          IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+

     &    isign(2,k(n+i,2))

          IF(p(n+i,5).GE.pmth(2,ifld)) inum=i

        ENDIF

  350 CONTINUE

      IF(inum.EQ.0) THEN

        rmax=0d0

        DO 360 i=1,nep

          IF(isi(i).EQ.1.AND.pmsd(i).GE.pmqth2) THEN

            rpm=p(n+i,5)/pmsd(i)

            ifld=kfld(i)

            IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+

     &      isign(2,k(n+i,2))

            IF(rpm.GT.rmax.AND.p(n+i,5).GE.pmth(2,ifld)) THEN

              rmax=rpm

              inum=i

            ENDIF

          ENDIF

  360   CONTINUE

      ENDIF


C...Store information on choice of evolving daughter.

      inum=max(1,inum)

      iep(1)=n+inum

      DO 370 i=2,nep

        iep(i)=iep(i-1)+1

        IF(iep(i).GT.n+nep) iep(i)=n+1

  370 CONTINUE

      DO 380 i=1,nep

        kfl(i)=iabs(k(iep(i),2))

  380 CONTINUE

      itry(inum)=itry(inum)+1

      IF(itry(inum).GT.200) THEN

        CALL pyerrm(14,'(PYSHOW:) caught in infinite loop')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      z=0.5d0

      IF(kfl(1).GT.40) goto 430

      IF(ksh(kfl(1)).EQ.0) goto 430

      ifl=kfl(1)

      IF(kfl(1).GE.6.AND.kfl(1).LE.8) ifl=37+kfl(1)+

     &isign(2,k(iep(1),2))

      IF(p(iep(1),5).LT.pmth(2,ifl)) goto 430


C...Select side for interference with initial state partons.

      IF(miis.GE.1.AND.iep(1).LE.ns+3) THEN

        iii=iep(1)-ns-1

        isii(iii)=0

        IF(iabs(kcii(iii)).EQ.1.AND.niis(iii).EQ.1) THEN

          isii(iii)=1

        ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.1) THEN

          IF(pyr(0).GT.0.5d0) isii(iii)=1

        ELSEIF(kcii(iii).EQ.2.AND.niis(iii).EQ.2) THEN

          isii(iii)=1

          IF(pyr(0).GT.0.5d0) isii(iii)=2

        ENDIF

      ENDIF


C...Calculate allowed z range.

      IF(nep.EQ.1) THEN

        pmed=ps(4)

      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN

        pmed=p(im,5)

      ELSE

        IF(inum.EQ.1) pmed=v(im,1)*pem

        IF(inum.EQ.2) pmed=(1d0-v(im,1))*pem

      ENDIF

      IF(mod(mstj(43),2).EQ.1) THEN

        zc=pmth(2,21)/pmed

        zce=pmth(2,22)/pmed

      ELSE

        zc=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,21)/pmed)**2)))

        IF(zc.LT.1d-4) zc=(pmth(2,21)/pmed)**2

        zce=0.5d0*(1d0-sqrt(max(0d0,1d0-(2d0*pmth(2,22)/pmed)**2)))

        IF(zce.LT.1d-4) zce=(pmth(2,22)/pmed)**2

      ENDIF

      zc=min(zc,0.491d0)

      zce=min(zce,0.491d0)

      IF((mstj(41).EQ.1.AND.zc.GT.0.49d0).OR.(mstj(41).GE.2.AND.

     &min(zc,zce).GT.0.49d0)) THEN

        p(iep(1),5)=pmth(1,ifl)

        v(iep(1),5)=p(iep(1),5)**2

        goto 430

      ENDIF


C...Integral of Altarelli-Parisi z kernel for QCD.

      IF(mstj(49).EQ.0.AND.kfl(1).EQ.21) THEN

        fbr=6d0*log((1d0-zc)/zc)+mstj(45)*(0.5d0-zc)

      ELSEIF(mstj(49).EQ.0) THEN

        fbr=(8d0/3d0)*log((1d0-zc)/zc)


C...Integral of Altarelli-Parisi z kernel for scalar gluon.

      ELSEIF(mstj(49).EQ.1.AND.kfl(1).EQ.21) THEN

        fbr=(parj(87)+mstj(45)*parj(88))*(1d0-2d0*zc)

      ELSEIF(mstj(49).EQ.1) THEN

        fbr=(1d0-2d0*zc)/3d0

        IF(igm.EQ.0.AND.m3jc.EQ.1) fbr=4d0*fbr


C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.

      ELSEIF(kfl(1).EQ.21) THEN

        fbr=6d0*mstj(45)*(0.5d0-zc)

      ELSE

        fbr=2d0*log((1d0-zc)/zc)

      ENDIF


C...Reset QCD probability for lepton.

      IF(kfl(1).GE.11.AND.kfl(1).LE.18) fbr=0d0


C...Integral of Altarelli-Parisi kernel for photon emission.

      IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN

        fbre=(kchg(kfl(1),1)/3d0)**2*2d0*log((1d0-zce)/zce)

        IF(mstj(41).EQ.10) fbre=parj(84)*fbre

      ENDIF


C...Inner veto algorithm starts. Find maximum mass for evolution.

  390 pms=v(iep(1),5)

      IF(igm.GE.0) THEN

        pm2=0d0

        DO 400 i=2,nep

          pm=p(iep(i),5)

          IF(kfl(i).LE.40) THEN

            ifli=kfl(i)

            IF(kfl(i).GE.6.AND.kfl(i).LE.8) ifli=37+kfl(i)+

     &      isign(2,k(iep(i),2))

            IF(ksh(kfl(i)).EQ.1) pm=pmth(2,ifli)

          ENDIF

          pm2=pm2+pm

  400   CONTINUE

        pms=min(pms,(p(im,5)-pm2)**2)

      ENDIF


C...Select mass for daughter in QCD evolution.

      b0=27d0/6d0

      DO 410 iff=4,mstj(45)

        IF(pms.GT.4d0*pmth(2,iff)**2) b0=(33d0-2d0*iff)/6d0

  410 CONTINUE

      IF(fbr.LT.1d-3) THEN

        pmsqcd=0d0

      ELSEIF(mstj(44).LE.0) THEN

        pmsqcd=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(111)*fbr)))

      ELSEIF(mstj(44).EQ.1) THEN

        pmsqcd=4d0*alams*(0.25d0*pms/alams)**(pyr(0)**(b0/fbr))

      ELSE

        pmsqcd=pms*exp(max(-50d0,alfm*b0*log(pyr(0))/fbr))

      ENDIF

      IF(zc.GT.0.49d0.OR.pmsqcd.LE.pmth(4,ifl)**2) pmsqcd=pmth(2,ifl)**2

      v(iep(1),5)=pmsqcd

      mce=1


C...Select mass for daughter in QED evolution.

      IF(mstj(41).GE.2.AND.kfl(1).GE.1.AND.kfl(1).LE.18) THEN

        pmsqed=pms*exp(max(-50d0,log(pyr(0))*paru(2)/(paru(101)*fbre)))

        IF(zce.GT.0.49d0.OR.pmsqed.LE.pmth(5,ifl)**2) pmsqed=

     &  pmth(2,ifl)**2

        IF(pmsqed.GT.pmsqcd) THEN

          v(iep(1),5)=pmsqed

          mce=2

        ENDIF

      ENDIF


C...Check whether daughter mass below cutoff.

      p(iep(1),5)=sqrt(v(iep(1),5))

      IF(p(iep(1),5).LE.pmth(3,ifl)) THEN

        p(iep(1),5)=pmth(1,ifl)

        v(iep(1),5)=p(iep(1),5)**2

        goto 430

      ENDIF


C...Select z value of branching: q -> qgamma.

      IF(mce.EQ.2) THEN

        z=1d0-(1d0-zce)*(zce/(1d0-zce))**pyr(0)

        IF(1d0+z**2.LT.2d0*pyr(0)) goto 390

        k(iep(1),5)=22


C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.

      ELSEIF(mstj(49).NE.1.AND.kfl(1).NE.21) THEN

        z=1d0-(1d0-zc)*(zc/(1d0-zc))**pyr(0)

        IF(1d0+z**2.LT.2d0*pyr(0)) goto 390

        k(iep(1),5)=21

      ELSEIF(mstj(49).EQ.0.AND.mstj(45)*(0.5d0-zc).LT.pyr(0)*fbr) THEN

        z=(1d0-zc)*(zc/(1d0-zc))**pyr(0)

        IF(pyr(0).GT.0.5d0) z=1d0-z

        IF((1d0-z*(1d0-z))**2.LT.pyr(0)) goto 390

        k(iep(1),5)=21

      ELSEIF(mstj(49).NE.1) THEN

        z=zc+(1d0-2d0*zc)*pyr(0)

        IF(z**2+(1d0-z)**2.LT.pyr(0)) goto 390

        kflb=1+int(mstj(45)*pyr(0))

        pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)

        IF(pmq.GE.1d0) goto 390

        pmq0=4d0*pmth(2,21)**2/v(iep(1),5)

        IF(mod(mstj(43),2).EQ.0.AND.(1d0+0.5d0*pmq)*sqrt(1d0-pmq).LT.

     &  pyr(0)*(1d0+0.5d0*pmq0)*sqrt(1d0-pmq0)) goto 390

        k(iep(1),5)=kflb


C...Ditto for scalar gluon model.

      ELSEIF(kfl(1).NE.21) THEN

        z=1d0-sqrt(zc**2+pyr(0)*(1d0-2d0*zc))

        k(iep(1),5)=21

      ELSEIF(pyr(0)*(parj(87)+mstj(45)*parj(88)).LE.parj(87)) THEN

        z=zc+(1d0-2d0*zc)*pyr(0)

        k(iep(1),5)=21

      ELSE

        z=zc+(1d0-2d0*zc)*pyr(0)

        kflb=1+int(mstj(45)*pyr(0))

        pmq=4d0*pmth(2,kflb)**2/v(iep(1),5)

        IF(pmq.GE.1d0) goto 390

        k(iep(1),5)=kflb

      ENDIF

      IF(mce.EQ.1.AND.mstj(44).GE.2) THEN

        IF(z*(1d0-z)*v(iep(1),5).LT.pt2min) goto 390

        IF(alfm/log(v(iep(1),5)*z*(1d0-z)/alams).LT.pyr(0)) goto 390

      ENDIF


C...Check if z consistent with chosen m.

      IF(kfl(1).EQ.21) THEN

        kflgd1=iabs(k(iep(1),5))

        kflgd2=kflgd1

      ELSE

        kflgd1=kfl(1)

        kflgd2=iabs(k(iep(1),5))

      ENDIF

      IF(nep.EQ.1) THEN

        ped=ps(4)

      ELSEIF(nep.GE.3) THEN

        ped=p(iep(1),4)

      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2) THEN

        ped=0.5d0*(v(im,5)+v(iep(1),5)-pm2**2)/p(im,5)

      ELSE

        IF(iep(1).EQ.n+1) ped=v(im,1)*pem

        IF(iep(1).EQ.n+2) ped=(1d0-v(im,1))*pem

      ENDIF

      IF(mod(mstj(43),2).EQ.1) THEN

        iflgd1=kflgd1

        IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=ifl

        pmqth3=0.5d0*parj(82)

        IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)

        pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(iep(1),5)

        pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(iep(1),5)

        zd=sqrt(max(0d0,(1d0-v(iep(1),5)/ped**2)*((1d0-pmq1-pmq2)**2-

     &  4d0*pmq1*pmq2)))

        zh=1d0+pmq1-pmq2

      ELSE

        zd=sqrt(max(0d0,1d0-v(iep(1),5)/ped**2))

        zh=1d0

      ENDIF

      zl=0.5d0*(zh-zd)

      zu=0.5d0*(zh+zd)

      IF(z.LT.zl.OR.z.GT.zu) goto 390

      IF(kfl(1).EQ.21) v(iep(1),3)=log(zu*(1d0-zl)/max(1d-20,zl*

     &(1d0-zu)))

      IF(kfl(1).NE.21) v(iep(1),3)=log((1d0-zl)/max(1d-10,1d0-zu))


C...Width suppression for q -> q + g.

      IF(mstj(40).NE.0.AND.kfl(1).NE.21) THEN

        IF(igm.EQ.0) THEN

          eglu=0.5d0*ps(5)*(1d0-z)*(1d0+v(iep(1),5)/v(ns+1,5))

        ELSE

          eglu=pmed*(1d0-z)

        ENDIF

        chi=parj(89)**2/(parj(89)**2+eglu**2)

        IF(mstj(40).EQ.1) THEN

          IF(chi.LT.pyr(0)) goto 390

        ELSEIF(mstj(40).EQ.2) THEN

          IF(1d0-chi.LT.pyr(0)) goto 390

        ENDIF

      ENDIF


C...Three-jet matrix element correction.

      IF(igm.EQ.0.AND.m3jc.EQ.1) THEN

        x1=z*(1d0+v(iep(1),5)/v(ns+1,5))

        x2=1d0-v(iep(1),5)/v(ns+1,5)

        x3=(1d0-x1)+(1d0-x2)

        IF(mce.EQ.2) THEN

          ki1=k(ipa(inum),2)

          ki2=k(ipa(3-inum),2)

          qf1=kchg(iabs(ki1),1)*isign(1,ki1)/3d0

          qf2=kchg(iabs(ki2),1)*isign(1,ki2)/3d0

          wshow=qf1**2*(1d0-x1)/x3*(1d0+(x1/(2d0-x2))**2)+

     &    qf2**2*(1d0-x2)/x3*(1d0+(x2/(2d0-x1))**2)

          wme=(qf1*(1d0-x1)/x3-qf2*(1d0-x2)/x3)**2*(x1**2+x2**2)

        ELSEIF(mstj(49).NE.1) THEN

          wshow=1d0+(1d0-x1)/x3*(x1/(2d0-x2))**2+

     &    (1d0-x2)/x3*(x2/(2d0-x1))**2

          wme=x1**2+x2**2

          IF(m3jcm.EQ.1) wme=wme-qme*x3-0.5d0*qme**2-

     &    (0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/max(1d-7,1d0-x1)+

     &    (1d0-x1)/max(1d-7,1d0-x2))

        ELSE

          wshow=4d0*x3*((1d0-x1)/(2d0-x2)**2+(1d0-x2)/(2d0-x1)**2)

          wme=x3**2

          IF(mstj(102).GE.2) wme=x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*

     &    parj(171)

        ENDIF

        IF(wme.LT.pyr(0)*wshow) goto 390


C...Impose angular ordering by rejection of nonordered emission.

      ELSEIF(mce.EQ.1.AND.igm.GT.0.AND.mstj(42).GE.2) THEN

        maom=1

        zm=v(im,1)

        IF(iep(1).EQ.n+2) zm=1d0-v(im,1)

        the2id=z*(1d0-z)*(zm*p(im,4))**2/v(iep(1),5)

        iaom=im

  420   IF(k(iaom,5).EQ.22) THEN

          iaom=k(iaom,3)

          IF(k(iaom,3).LE.ns) maom=0

          IF(maom.EQ.1) goto 420

        ENDIF

        IF(maom.EQ.1) THEN

          the2im=v(iaom,1)*(1d0-v(iaom,1))*p(iaom,4)**2/v(iaom,5)

          IF(the2id.LT.the2im) goto 390

        ENDIF

      ENDIF


C...Impose user-defined maximum angle at first branching.

      IF(mstj(48).EQ.1) THEN

        IF(nep.EQ.1.AND.im.EQ.ns) THEN

          the2id=z*(1d0-z)*ps(4)**2/v(iep(1),5)

          IF(the2id.LT.1d0/parj(85)**2) goto 390

        ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+2) THEN

          the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)

          IF(the2id.LT.1d0/parj(85)**2) goto 390

        ELSEIF(nep.EQ.2.AND.iep(1).EQ.ns+3) THEN

          the2id=z*(1d0-z)*(0.5d0*p(im,4))**2/v(iep(1),5)

          IF(the2id.LT.1d0/parj(86)**2) goto 390

        ENDIF

      ENDIF


C...Impose angular constraint in first branching from interference

C...with initial state partons.

      IF(miis.GE.2.AND.iep(1).LE.ns+3) THEN

        the2d=max((1d0-z)/z,z/(1d0-z))*v(iep(1),5)/(0.5d0*p(im,4))**2

        IF(iep(1).EQ.ns+2.AND.isii(1).GE.1) THEN

          IF(the2d.GT.theiis(1,isii(1))**2) goto 390

        ELSEIF(iep(1).EQ.ns+3.AND.isii(2).GE.1) THEN

          IF(the2d.GT.theiis(2,isii(2))**2) goto 390

        ENDIF

      ENDIF


C...End of inner veto algorithm. Check if only one leg evolved so far.

  430 v(iep(1),1)=z

      isl(1)=0

      isl(2)=0

      IF(nep.EQ.1) goto 460

      IF(nep.EQ.2.AND.p(iep(1),5)+p(iep(2),5).GE.p(im,5)) goto 330

      DO 440 i=1,nep

        IF(itry(i).EQ.0.AND.kfld(i).LE.40) THEN

          IF(ksh(kfld(i)).EQ.1) THEN

            ifld=kfld(i)

            IF(kfld(i).GE.6.AND.kfld(i).LE.8) ifld=37+kfld(i)+

     &      isign(2,k(n+i,2))

            IF(p(n+i,5).GE.pmth(2,ifld)) goto 330

          ENDIF

        ENDIF

  440 CONTINUE


C...Check if chosen multiplet m1,m2,z1,z2 is physical.

      IF(nep.EQ.3) THEN

        pa1s=(p(n+1,4)+p(n+1,5))*(p(n+1,4)-p(n+1,5))

        pa2s=(p(n+2,4)+p(n+2,5))*(p(n+2,4)-p(n+2,5))

        pa3s=(p(n+3,4)+p(n+3,5))*(p(n+3,4)-p(n+3,5))

        pts=0.25d0*(2d0*pa1s*pa2s+2d0*pa1s*pa3s+2d0*pa2s*pa3s-

     &  pa1s**2-pa2s**2-pa3s**2)/pa1s

        IF(pts.LE.0d0) goto 330

      ELSEIF(igm.EQ.0.OR.mstj(43).LE.2.OR.mod(mstj(43),2).EQ.0) THEN

        DO 450 i1=n+1,n+2

          kflda=iabs(k(i1,2))

          IF(kflda.GT.40) goto 450

          IF(ksh(kflda).EQ.0) goto 450

          iflda=kflda

          IF(kflda.GE.6.AND.kflda.LE.8) iflda=37+kflda+

     &    isign(2,k(i1,2))

          IF(p(i1,5).LT.pmth(2,iflda)) goto 450

          IF(kflda.EQ.21) THEN

            kflgd1=iabs(k(i1,5))

            kflgd2=kflgd1

          ELSE

            kflgd1=kflda

            kflgd2=iabs(k(i1,5))

          ENDIF

          i2=2*n+3-i1

          IF(igm.EQ.0.OR.mstj(43).LE.2) THEN

            ped=0.5d0*(v(im,5)+v(i1,5)-v(i2,5))/p(im,5)

          ELSE

            IF(i1.EQ.n+1) zm=v(im,1)

            IF(i1.EQ.n+2) zm=1d0-v(im,1)

            pml=sqrt((v(im,5)-v(n+1,5)-v(n+2,5))**2-

     &      4d0*v(n+1,5)*v(n+2,5))

            ped=pem*(0.5d0*(v(im,5)-pml+v(i1,5)-v(i2,5))+pml*zm)/v(im,5)

          ENDIF

          IF(mod(mstj(43),2).EQ.1) THEN

            pmqth3=0.5d0*parj(82)

            IF(kflgd2.EQ.22) pmqth3=0.5d0*parj(83)

            iflgd1=kflgd1

            IF(kflgd1.GE.6.AND.kflgd1.LE.8) iflgd1=iflda

            pmq1=(pmth(1,iflgd1)**2+pmqth3**2)/v(i1,5)

            pmq2=(pmth(1,kflgd2)**2+pmqth3**2)/v(i1,5)

            zd=sqrt(max(0d0,(1d0-v(i1,5)/ped**2)*((1d0-pmq1-pmq2)**2-

     &      4d0*pmq1*pmq2)))

            zh=1d0+pmq1-pmq2

          ELSE

            zd=sqrt(max(0d0,1d0-v(i1,5)/ped**2))

            zh=1d0

          ENDIF

          zl=0.5d0*(zh-zd)

          zu=0.5d0*(zh+zd)

          IF(i1.EQ.n+1.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(1)=1

          IF(i1.EQ.n+2.AND.(v(i1,1).LT.zl.OR.v(i1,1).GT.zu)) isl(2)=1

          IF(kflda.EQ.21) v(i1,4)=log(zu*(1d0-zl)/max(1d-20,

     &    zl*(1d0-zu)))

          IF(kflda.NE.21) v(i1,4)=log((1d0-zl)/max(1d-10,1d0-zu))

  450   CONTINUE

        IF(isl(1).EQ.1.AND.isl(2).EQ.1.AND.islm.NE.0) THEN

          isl(3-islm)=0

          islm=3-islm

        ELSEIF(isl(1).EQ.1.AND.isl(2).EQ.1) THEN

          zdr1=max(0d0,v(n+1,3)/max(1d-6,v(n+1,4))-1d0)

          zdr2=max(0d0,v(n+2,3)/max(1d-6,v(n+2,4))-1d0)

          IF(zdr2.GT.pyr(0)*(zdr1+zdr2)) isl(1)=0

          IF(isl(1).EQ.1) isl(2)=0

          IF(isl(1).EQ.0) islm=1

          IF(isl(2).EQ.0) islm=2

        ENDIF

        IF(isl(1).EQ.1.OR.isl(2).EQ.1) goto 330

      ENDIF

      ifld1=kfld(1)

      IF(kfld(1).GE.6.AND.kfld(1).LE.8) ifld1=37+kfld(1)+

     &isign(2,k(n+1,2))

      ifld2=kfld(2)

      IF(kfld(2).GE.6.AND.kfld(2).LE.8) ifld2=37+kfld(2)+

     &isign(2,k(n+2,2))

      IF(igm.GT.0.AND.mod(mstj(43),2).EQ.1.AND.(p(n+1,5).GE.

     &pmth(2,ifld1).OR.p(n+2,5).GE.pmth(2,ifld2))) THEN

        pmq1=v(n+1,5)/v(im,5)

        pmq2=v(n+2,5)/v(im,5)

        zd=sqrt(max(0d0,(1d0-v(im,5)/pem**2)*((1d0-pmq1-pmq2)**2-

     &  4d0*pmq1*pmq2)))

        zh=1d0+pmq1-pmq2

        zl=0.5d0*(zh-zd)

        zu=0.5d0*(zh+zd)

        IF(v(im,1).LT.zl.OR.v(im,1).GT.zu) goto 330

      ENDIF


C...Accepted branch. Construct four-momentum for initial partons.

  460 mazip=0

      mazic=0

      IF(nep.EQ.1) THEN

        p(n+1,1)=0d0

        p(n+1,2)=0d0

        p(n+1,3)=sqrt(max(0d0,(p(ipa(1),4)+p(n+1,5))*(p(ipa(1),4)-

     &  p(n+1,5))))

        p(n+1,4)=p(ipa(1),4)

        v(n+1,2)=p(n+1,4)

      ELSEIF(igm.EQ.0.AND.nep.EQ.2) THEN

        ped1=0.5d0*(v(im,5)+v(n+1,5)-v(n+2,5))/p(im,5)

        p(n+1,1)=0d0

        p(n+1,2)=0d0

        p(n+1,3)=sqrt(max(0d0,(ped1+p(n+1,5))*(ped1-p(n+1,5))))

        p(n+1,4)=ped1

        p(n+2,1)=0d0

        p(n+2,2)=0d0

        p(n+2,3)=-p(n+1,3)

        p(n+2,4)=p(im,5)-ped1

        v(n+1,2)=p(n+1,4)

        v(n+2,2)=p(n+2,4)

      ELSEIF(nep.EQ.3) THEN

        p(n+1,1)=0d0

        p(n+1,2)=0d0

        p(n+1,3)=sqrt(max(0d0,pa1s))

        p(n+2,1)=sqrt(pts)

        p(n+2,2)=0d0

        p(n+2,3)=0.5d0*(pa3s-pa2s-pa1s)/p(n+1,3)

        p(n+3,1)=-p(n+2,1)

        p(n+3,2)=0d0

        p(n+3,3)=-(p(n+1,3)+p(n+2,3))

        v(n+1,2)=p(n+1,4)

        v(n+2,2)=p(n+2,4)

        v(n+3,2)=p(n+3,4)


C...Construct transverse momentum for ordinary branching in shower.

      ELSE

        zm=v(im,1)

        pzm=sqrt(max(0d0,(pem+p(im,5))*(pem-p(im,5))))

        pmls=(v(im,5)-v(n+1,5)-v(n+2,5))**2-4d0*v(n+1,5)*v(n+2,5)

        IF(pzm.LE.0d0) THEN

          pts=0d0

        ELSEIF(mod(mstj(43),2).EQ.1) THEN

          pts=(pem**2*(zm*(1d0-zm)*v(im,5)-(1d0-zm)*v(n+1,5)-

     &    zm*v(n+2,5))-0.25d0*pmls)/pzm**2

        ELSE

          pts=pmls*(zm*(1d0-zm)*pem**2/v(im,5)-0.25d0)/pzm**2

        ENDIF

        pt=sqrt(max(0d0,pts))


C...Find coefficient of azimuthal asymmetry due to gluon polarization.

        hazip=0d0

        IF(mstj(49).NE.1.AND.mod(mstj(46),2).EQ.1.AND.k(im,2).EQ.21

     &  .AND.iau.NE.0) THEN

          IF(k(igm,3).NE.0) mazip=1

          zau=v(igm,1)

          IF(iau.EQ.im+1) zau=1d0-v(igm,1)

          IF(mazip.EQ.0) zau=0d0

          IF(k(igm,2).NE.21) THEN

            hazip=2d0*zau/(1d0+zau**2)

          ELSE

            hazip=(zau/(1d0-zau*(1d0-zau)))**2

          ENDIF

          IF(k(n+1,2).NE.21) THEN

            hazip=hazip*(-2d0*zm*(1d0-zm))/(1d0-2d0*zm*(1d0-zm))

          ELSE

            hazip=hazip*(zm*(1d0-zm)/(1d0-zm*(1d0-zm)))**2

          ENDIF

        ENDIF


C...Find coefficient of azimuthal asymmetry due to soft gluon

C...interference.

        hazic=0d0

        IF(mstj(49).NE.2.AND.mstj(46).GE.2.AND.(k(n+1,2).EQ.21.OR.

     &  k(n+2,2).EQ.21).AND.iau.NE.0) THEN

          IF(k(igm,3).NE.0) mazic=n+1

          IF(k(igm,3).NE.0.AND.k(n+1,2).NE.21) mazic=n+2

          IF(k(igm,3).NE.0.AND.k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.

     &    zm.GT.0.5d0) mazic=n+2

          IF(k(iau,2).EQ.22) mazic=0

          zs=zm

          IF(mazic.EQ.n+2) zs=1d0-zm

          zgm=v(igm,1)

          IF(iau.EQ.im-1) zgm=1d0-v(igm,1)

          IF(mazic.EQ.0) zgm=1d0

          IF(mazic.NE.0) hazic=(p(im,5)/p(igm,5))*

     &    sqrt((1d0-zs)*(1d0-zgm)/(zs*zgm))

          hazic=min(0.95d0,hazic)

        ENDIF

      ENDIF


C...Construct kinematics for ordinary branching in shower.

  470 IF(nep.EQ.2.AND.igm.GT.0) THEN

        IF(mod(mstj(43),2).EQ.1) THEN

          p(n+1,4)=pem*v(im,1)

        ELSE

          p(n+1,4)=pem*(0.5d0*(v(im,5)-sqrt(pmls)+v(n+1,5)-v(n+2,5))+

     &    sqrt(pmls)*zm)/v(im,5)

        ENDIF

        phi=paru(2)*pyr(0)

        p(n+1,1)=pt*cos(phi)

        p(n+1,2)=pt*sin(phi)

        IF(pzm.GT.0d0) THEN

          p(n+1,3)=0.5d0*(v(n+2,5)-v(n+1,5)-v(im,5)+

     &    2d0*pem*p(n+1,4))/pzm

        ELSE

          p(n+1,3)=0d0

        ENDIF

        p(n+2,1)=-p(n+1,1)

        p(n+2,2)=-p(n+1,2)

        p(n+2,3)=pzm-p(n+1,3)

        p(n+2,4)=pem-p(n+1,4)

        IF(mstj(43).LE.2) THEN

          v(n+1,2)=(pem*p(n+1,4)-pzm*p(n+1,3))/p(im,5)

          v(n+2,2)=(pem*p(n+2,4)-pzm*p(n+2,3))/p(im,5)

        ENDIF

      ENDIF


C...Rotate and boost daughters.

      IF(igm.GT.0) THEN

        IF(mstj(43).LE.2) THEN

          bex=p(igm,1)/p(igm,4)

          bey=p(igm,2)/p(igm,4)

          bez=p(igm,3)/p(igm,4)

          ga=p(igm,4)/p(igm,5)

          gabep=ga*(ga*(bex*p(im,1)+bey*p(im,2)+bez*p(im,3))/(1d0+ga)-

     &    p(im,4))

        ELSE

          bex=0d0

          bey=0d0

          bez=0d0

          ga=1d0

          gabep=0d0

        ENDIF

        the=pyangl(p(im,3)+gabep*bez,sqrt((p(im,1)+gabep*bex)**2+

     &  (p(im,2)+gabep*bey)**2))

        phi=pyangl(p(im,1)+gabep*bex,p(im,2)+gabep*bey)

        DO 480 i=n+1,n+2

          dp(1)=cos(the)*cos(phi)*p(i,1)-sin(phi)*p(i,2)+

     &    sin(the)*cos(phi)*p(i,3)

          dp(2)=cos(the)*sin(phi)*p(i,1)+cos(phi)*p(i,2)+

     &    sin(the)*sin(phi)*p(i,3)

          dp(3)=-sin(the)*p(i,1)+cos(the)*p(i,3)

          dp(4)=p(i,4)

          dbp=bex*dp(1)+bey*dp(2)+bez*dp(3)

          dgabp=ga*(ga*dbp/(1d0+ga)+dp(4))

          p(i,1)=dp(1)+dgabp*bex

          p(i,2)=dp(2)+dgabp*bey

          p(i,3)=dp(3)+dgabp*bez

          p(i,4)=ga*(dp(4)+dbp)

  480   CONTINUE

      ENDIF


C...Weight with azimuthal distribution, if required.

      IF(mazip.NE.0.OR.mazic.NE.0) THEN

        DO 490 j=1,3

          dpt(1,j)=p(im,j)

          dpt(2,j)=p(iau,j)

          dpt(3,j)=p(n+1,j)

  490   CONTINUE

        dpma=dpt(1,1)*dpt(2,1)+dpt(1,2)*dpt(2,2)+dpt(1,3)*dpt(2,3)

        dpmd=dpt(1,1)*dpt(3,1)+dpt(1,2)*dpt(3,2)+dpt(1,3)*dpt(3,3)

        dpmm=dpt(1,1)**2+dpt(1,2)**2+dpt(1,3)**2

        DO 500 j=1,3

          dpt(4,j)=dpt(2,j)-dpma*dpt(1,j)/dpmm

          dpt(5,j)=dpt(3,j)-dpmd*dpt(1,j)/dpmm

  500   CONTINUE

        dpt(4,4)=sqrt(dpt(4,1)**2+dpt(4,2)**2+dpt(4,3)**2)

        dpt(5,4)=sqrt(dpt(5,1)**2+dpt(5,2)**2+dpt(5,3)**2)

        IF(min(dpt(4,4),dpt(5,4)).GT.0.1d0*parj(82)) THEN

          cad=(dpt(4,1)*dpt(5,1)+dpt(4,2)*dpt(5,2)+

     &    dpt(4,3)*dpt(5,3))/(dpt(4,4)*dpt(5,4))

          IF(mazip.NE.0) THEN

            IF(1d0+hazip*(2d0*cad**2-1d0).LT.pyr(0)*(1d0+abs(hazip)))

     &      goto 470

          ENDIF

          IF(mazic.NE.0) THEN

            IF(mazic.EQ.n+2) cad=-cad

            IF((1d0-hazic)*(1d0-hazic*cad)/(1d0+hazic**2-2d0*hazic*cad)

     &      .LT.pyr(0)) goto 470

          ENDIF

        ENDIF

      ENDIF


C...Azimuthal anisotropy due to interference with initial state partons.

      IF(mod(miis,2).EQ.1.AND.igm.EQ.ns+1.AND.(k(n+1,2).EQ.21.OR.

     &k(n+2,2).EQ.21)) THEN

        iii=im-ns-1

        IF(isii(iii).GE.1) THEN

          iaziid=n+1

          IF(k(n+1,2).NE.21) iaziid=n+2

          IF(k(n+1,2).EQ.21.AND.k(n+2,2).EQ.21.AND.

     &    p(n+1,4).GT.p(n+2,4)) iaziid=n+2

          theiid=pyangl(p(iaziid,3),sqrt(p(iaziid,1)**2+p(iaziid,2)**2))

          IF(iii.EQ.2) theiid=paru(1)-theiid

          phiiid=pyangl(p(iaziid,1),p(iaziid,2))

          hazii=min(0.95d0,theiid/theiis(iii,isii(iii)))

          cad=cos(phiiid-phiiis(iii,isii(iii)))

          phirel=abs(phiiid-phiiis(iii,isii(iii)))

          IF(phirel.GT.paru(1)) phirel=paru(2)-phirel

          IF((1d0-hazii)*(1d0-hazii*cad)/(1d0+hazii**2-2d0*hazii*cad)

     &    .LT.pyr(0)) goto 470

        ENDIF

      ENDIF


C...Continue loop over partons that may branch, until none left.

      IF(igm.GE.0) k(im,1)=14

      n=n+nep

      nep=2

      IF(n.GT.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYSHOW:) no more memory left in PYJETS')

        IF(mstu(21).GE.1) n=ns

        IF(mstu(21).GE.1) RETURN

      ENDIF

      goto 270


C...Set information on imagined shower initiator.

  510 IF(npa.GE.2) THEN

        k(ns+1,1)=11

        k(ns+1,2)=94

        k(ns+1,3)=ip1

        IF(ip2.GT.0.AND.ip2.LT.ip1) k(ns+1,3)=ip2

        k(ns+1,4)=ns+2

        k(ns+1,5)=ns+1+npa

        iim=1

      ELSE

        iim=0

      ENDIF


C...Reconstruct string drawing information.

      DO 520 i=ns+1+iim,n

        IF(k(i,1).LE.10.AND.k(i,2).EQ.22) THEN

          k(i,1)=1

        ELSEIF(k(i,1).LE.10.AND.iabs(k(i,2)).GE.11.AND.

     &    iabs(k(i,2)).LE.18) THEN

          k(i,1)=1

        ELSEIF(k(i,1).LE.10) THEN

          k(i,4)=mstu(5)*(k(i,4)/mstu(5))

          k(i,5)=mstu(5)*(k(i,5)/mstu(5))

        ELSEIF(k(mod(k(i,4),mstu(5))+1,2).NE.22) THEN

          id1=mod(k(i,4),mstu(5))

          IF(k(i,2).GE.1.AND.k(i,2).LE.8) id1=mod(k(i,4),mstu(5))+1

          id2=2*mod(k(i,4),mstu(5))+1-id1

          k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1

          k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id2

          k(id1,4)=k(id1,4)+mstu(5)*i

          k(id1,5)=k(id1,5)+mstu(5)*id2

          k(id2,4)=k(id2,4)+mstu(5)*id1

          k(id2,5)=k(id2,5)+mstu(5)*i

        ELSE

          id1=mod(k(i,4),mstu(5))

          id2=id1+1

          k(i,4)=mstu(5)*(k(i,4)/mstu(5))+id1

          k(i,5)=mstu(5)*(k(i,5)/mstu(5))+id1

          IF(iabs(k(i,2)).LE.10.OR.k(id1,1).GE.11) THEN

            k(id1,4)=k(id1,4)+mstu(5)*i

            k(id1,5)=k(id1,5)+mstu(5)*i

          ELSE

            k(id1,4)=0

            k(id1,5)=0

          ENDIF

          k(id2,4)=0

          k(id2,5)=0

        ENDIF

  520 CONTINUE


C...Transformation from CM frame.

      IF(npa.GE.2) THEN

        bex=ps(1)/ps(4)

        bey=ps(2)/ps(4)

        bez=ps(3)/ps(4)

        ga=ps(4)/ps(5)

        gabep=ga*(ga*(bex*p(ipa(1),1)+bey*p(ipa(1),2)+bez*p(ipa(1),3))

     &  /(1d0+ga)-p(ipa(1),4))

      ELSE

        bex=0d0

        bey=0d0

        bez=0d0

        gabep=0d0

      ENDIF

      the=pyangl(p(ipa(1),3)+gabep*bez,sqrt((p(ipa(1),1)

     &+gabep*bex)**2+(p(ipa(1),2)+gabep*bey)**2))

      phi=pyangl(p(ipa(1),1)+gabep*bex,p(ipa(1),2)+gabep*bey)

      IF(npa.EQ.3) THEN

        chi=pyangl(cos(the)*cos(phi)*(p(ipa(2),1)+gabep*bex)+cos(the)*

     &  sin(phi)*(p(ipa(2),2)+gabep*bey)-sin(the)*(p(ipa(2),3)+gabep*

     &  bez),-sin(phi)*(p(ipa(2),1)+gabep*bex)+cos(phi)*(p(ipa(2),2)+

     &  gabep*bey))

        mstu(33)=1

        CALL pyrobo(ns+1,n,0d0,chi,0d0,0d0,0d0)

      ENDIF

      mstu(33)=1

      CALL pyrobo(ns+1,n,the,phi,bex,bey,bez)


C...Decay vertex of shower.

      DO 540 i=ns+1,n

        DO 530 j=1,5

          v(i,j)=v(ip1,j)

  530   CONTINUE

  540 CONTINUE


C...Delete trivial shower, else connect initiators.

      IF(n.EQ.ns+npa+iim) THEN

        n=ns

      ELSE

        DO 550 ip=1,npa

          k(ipa(ip),1)=14

          k(ipa(ip),4)=k(ipa(ip),4)+ns+iim+ip

          k(ipa(ip),5)=k(ipa(ip),5)+ns+iim+ip

          k(ns+iim+ip,3)=ipa(ip)

          IF(iim.EQ.1.AND.mstu(16).NE.2) k(ns+iim+ip,3)=ns+1

          IF(k(ns+iim+ip,1).NE.1) THEN

            k(ns+iim+ip,4)=mstu(5)*ipa(ip)+k(ns+iim+ip,4)

            k(ns+iim+ip,5)=mstu(5)*ipa(ip)+k(ns+iim+ip,5)

          ENDIF

  550   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYBOEI

C...Modifies an event so as to approximately take into account

C...Bose-Einstein effects according to a simple phenomenological

C...parametrization.


      SUBROUTINE pyboei(NSAV)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pyjets/,/pydat1/

C...Local arrays and data.

      dimension dps(4),kfbe(9),nbe(0:9),bei(100)

      DATA kfbe/211,-211,111,321,-321,130,310,221,331/


C...Boost event to overall CM frame. Calculate CM energy.

      IF((mstj(51).NE.1.AND.mstj(51).NE.2).OR.n-nsav.LE.1) RETURN

      DO 100 j=1,4

        dps(j)=0d0

  100 CONTINUE

      DO 120 i=1,n

        kfa=iabs(k(i,2))

        IF(k(i,1).LE.10.AND.((kfa.GT.10.AND.kfa.LE.20).OR.kfa.EQ.22)

     &  .AND.k(i,3).GT.0) THEN

          kfma=iabs(k(k(i,3),2))

          IF(kfma.GT.10.AND.kfma.LE.80) k(i,1)=-k(i,1)

        ENDIF

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 120

        DO 110 j=1,4

          dps(j)=dps(j)+p(i,j)

  110   CONTINUE

  120 CONTINUE

      CALL pyrobo(0,0,0d0,0d0,-dps(1)/dps(4),-dps(2)/dps(4),

     &-dps(3)/dps(4))

      pecm=0d0

      DO 130 i=1,n

        IF(k(i,1).GE.1.AND.k(i,1).LE.10) pecm=pecm+p(i,4)

  130 CONTINUE


C...Reserve copy of particles by species at end of record.

      nbe(0)=n+mstu(3)

      DO 160 ibe=1,min(9,mstj(52))

        nbe(ibe)=nbe(ibe-1)

        DO 150 i=nsav+1,n

          IF(k(i,2).NE.kfbe(ibe)) goto 150

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 150

          IF(nbe(ibe).GE.mstu(4)-mstu(32)-5) THEN

            CALL pyerrm(11,'(PYBOEI:) no more memory left in PYJETS')

            RETURN

          ENDIF

          nbe(ibe)=nbe(ibe)+1

          k(nbe(ibe),1)=i

          DO 140 j=1,3

            p(nbe(ibe),j)=0d0

  140     CONTINUE

  150   CONTINUE

  160 CONTINUE

      IF(nbe(min(9,mstj(52)))-nbe(0).LE.1) goto 280


C...Tabulate integral for subsequent momentum shift.

      DO 220 ibe=1,min(9,mstj(52))

        IF(ibe.NE.1.AND.ibe.NE.4.AND.ibe.LE.7) goto 180

        IF(ibe.EQ.1.AND.max(nbe(1)-nbe(0),nbe(2)-nbe(1),nbe(3)-nbe(2))

     &  .LE.1) goto 180

        IF(ibe.EQ.4.AND.max(nbe(4)-nbe(3),nbe(5)-nbe(4),nbe(6)-nbe(5),

     &  nbe(7)-nbe(6)).LE.1) goto 180

        IF(ibe.GE.8.AND.nbe(ibe)-nbe(ibe-1).LE.1) goto 180

        IF(ibe.EQ.1) pmhq=2d0*pymass(211)

        IF(ibe.EQ.4) pmhq=2d0*pymass(321)

        IF(ibe.EQ.8) pmhq=2d0*pymass(221)

        IF(ibe.EQ.9) pmhq=2d0*pymass(331)

        qdel=0.1d0*min(pmhq,parj(93))

        IF(mstj(51).EQ.1) THEN

          nbin=min(100,nint(9d0*parj(93)/qdel))

          beex=exp(0.5d0*qdel/parj(93))

          bert=exp(-qdel/parj(93))

        ELSE

          nbin=min(100,nint(3d0*parj(93)/qdel))

        ENDIF

        DO 170 ibin=1,nbin

          qbin=qdel*(ibin-0.5d0)

          bei(ibin)=qdel*(qbin**2+qdel**2/12d0)/sqrt(qbin**2+pmhq**2)

          IF(mstj(51).EQ.1) THEN

            beex=beex*bert

            bei(ibin)=bei(ibin)*beex

          ELSE

            bei(ibin)=bei(ibin)*exp(-(qbin/parj(93))**2)

          ENDIF

          IF(ibin.GE.2) bei(ibin)=bei(ibin)+bei(ibin-1)

  170   CONTINUE


C...Loop through particle pairs and find old relative momentum.

  180   DO 210 i1m=nbe(ibe-1)+1,nbe(ibe)-1

          i1=k(i1m,1)

          DO 200 i2m=i1m+1,nbe(ibe)

            i2=k(i2m,1)

            q2old=max(0d0,(p(i1,4)+p(i2,4))**2-(p(i1,1)+p(i2,1))**2-

     &      (p(i1,2)+ p(i2,2))**2-(p(i1,3)+p(i2,3))**2-

     &      (p(i1,5)+p(i2,5))**2)

            qold=sqrt(q2old)


C...Calculate new relative momentum.

            IF(qold.LT.1d-3*qdel) THEN

              goto 200

            ELSEIF(qold.LE.qdel) THEN

              qmov=qold/3d0

            ELSEIF(qold.LT.(nbin-0.1d0)*qdel) THEN

              rbin=qold/qdel

              ibin=rbin

              rinp=(rbin**3-ibin**3)/(3*ibin*(ibin+1)+1)

              qmov=(bei(ibin)+rinp*(bei(ibin+1)-bei(ibin)))*

     &        sqrt(q2old+pmhq**2)/q2old

            ELSE

              qmov=bei(nbin)*sqrt(q2old+pmhq**2)/q2old

            ENDIF

            q2new=q2old*(qold/(qold+3d0*parj(92)*qmov))**(2d0/3d0)


C...Calculate and save shift to be performed on three-momenta.

            hc1=(p(i1,4)+p(i2,4))**2-(q2old-q2new)

            hc2=(q2old-q2new)*(p(i1,4)-p(i2,4))**2

            ha=0.5d0*(1d0-sqrt(hc1*q2new/(hc1*q2old-hc2)))

            DO 190 j=1,3

              pd=ha*(p(i2,j)-p(i1,j))

              p(i1m,j)=p(i1m,j)+pd

              p(i2m,j)=p(i2m,j)-pd

  190       CONTINUE

  200     CONTINUE

  210   CONTINUE

  220 CONTINUE


C...Shift momenta and recalculate energies.

      DO 240 im=nbe(0)+1,nbe(min(9,mstj(52)))

        i=k(im,1)

        DO 230 j=1,3

          p(i,j)=p(i,j)+p(im,j)

  230   CONTINUE

        p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

  240 CONTINUE


C...Rescale all momenta for energy conservation.

      pes=0d0

      pqs=0d0

      DO 250 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 250

        pes=pes+p(i,4)

        pqs=pqs+p(i,5)**2/p(i,4)

  250 CONTINUE

      fac=(pecm-pqs)/(pes-pqs)

      DO 270 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 270

        DO 260 j=1,3

          p(i,j)=fac*p(i,j)

  260   CONTINUE

        p(i,4)=sqrt(p(i,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

  270 CONTINUE


C...Boost back to correct reference frame.

  280 CALL pyrobo(0,0,0d0,0d0,dps(1)/dps(4),dps(2)/dps(4),dps(3)/dps(4))

      DO 290 i=1,n

        IF(k(i,1).LT.0) k(i,1)=-k(i,1)

  290 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYMASS

C...Gives the mass of a particle/parton.


      FUNCTION pymass(KF)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Reset variables. Compressed code. Special case for popcorn diquarks.

      pymass=0d0

      kfa=iabs(kf)

      IF(kfa/10000.EQ.1.AND.mod(kfa/10,10).EQ.0) kfa=kfa-10000

      kc=pycomp(isign(kfa,kf))

      IF(kc.EQ.0) THEN

        mstj(93)=0

        RETURN

      ENDIF


C...Guarantee use of constituent masses for internal checks.

      IF((mstj(93).EQ.1.OR.mstj(93).EQ.2).AND.

     &(kfa.LE.10.OR.mod(kfa/10,10).EQ.0)) THEN

        parf(106)=pmas(6,1)

        parf(107)=pmas(7,1)

        parf(108)=pmas(8,1)

        IF(kfa.LE.10) THEN

          pymass=parf(100+kfa)

          IF(mstj(93).EQ.2) pymass=max(0d0,pymass-parf(121))

        ELSEIF(mstj(93).EQ.1) THEN

          pymass=parf(100+mod(kfa/1000,10))+parf(100+mod(kfa/100,10))

        ELSE

          pymass=max(0d0,pmas(kc,1)-parf(122)-2d0*parf(112)/3d0)

        ENDIF


C...Other masses can be read directly off table.

      ELSE

        pymass=pmas(kc,1)

      ENDIF


C...Optional mass broadening according to truncated Breit-Wigner

C...(either in m or in m^2).

      IF(mstj(24).GE.1.AND.pmas(kc,2).GT.1d-4) THEN

        IF(mstj(24).EQ.1.OR.(mstj(24).EQ.2.AND.kfa.GT.100)) THEN

          pymass=pymass+0.5d0*pmas(kc,2)*tan((2d0*pyr(0)-1d0)*

     &    atan(2d0*pmas(kc,3)/pmas(kc,2)))

        ELSE

          pm0=pymass

          pmlow=atan((max(0d0,pm0-pmas(kc,3))**2-pm0**2)/

     &    (pm0*pmas(kc,2)))

          pmupp=atan(((pm0+pmas(kc,3))**2-pm0**2)/(pm0*pmas(kc,2)))

          pymass=sqrt(max(0d0,pm0**2+pm0*pmas(kc,2)*tan(pmlow+

     &    (pmupp-pmlow)*pyr(0))))

        ENDIF

      ENDIF

      mstj(93)=0


      RETURN

      END


C*********************************************************************


C...PYNAME

C...Gives the particle/parton name as a character string.


      SUBROUTINE pyname(KF,CHAU)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      SAVE /pydat1/,/pydat2/,/pydat4/

C...Local character variable.

      CHARACTER chau*16


C...Read out code with distinction particle/antiparticle.

      chau=' '

      kc=pycomp(kf)

      IF(kc.NE.0) chau=chaf(kc,(3-isign(1,kf))/2)


      RETURN

      END


C*********************************************************************


C...PYCHGE

C...Gives three times the charge for a particle/parton.


      FUNCTION pychge(KF)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat2/


C...Read out charge and change sign for antiparticle.

      pychge=0

      kc=pycomp(kf)

      IF(kc.NE.0) pychge=kchg(kc,1)*isign(1,kf)


      RETURN

      END


C*********************************************************************


C...PYCOMP

C...Compress the standard KF codes for use in mass and decay arrays;

C...also checks whether a given code actually is defined.


      FUNCTION pycomp(KF)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/

C...Local arrays and saved data.

      dimension kford(100:500),kcord(101:500)

      SAVE kford,kcord,nford,kflast,kclast


C...Whenever necessary reorder codes for faster search.

      IF(mstu(20).EQ.0) THEN

        nford=100

        kford(100)=0

        DO 120 i=101,500

          kfa=kchg(i,4)

          IF(kfa.LE.100) goto 120

          nford=nford+1

          DO 100 i1=nford-1,0,-1

            IF(kfa.GE.kford(i1)) goto 110

            kford(i1+1)=kford(i1)

            kcord(i1+1)=kcord(i1)

  100     CONTINUE

  110     kford(i1+1)=kfa

          kcord(i1+1)=i

  120   CONTINUE

        mstu(20)=1

        kflast=0

        kclast=0

      ENDIF


C...Fast action if same code as in latest call.

      IF(kf.EQ.kflast) THEN

        pycomp=kclast

        RETURN

      ENDIF


C...Starting values.

      pycomp=0

      kfa=iabs(kf)


C...Simple cases: direct translation.

      IF(kfa.GT.kford(nford)) THEN

      ELSEIF(kfa.LE.100) THEN

        pycomp=kfa


C...Else binary search.

      ELSE

        imin=100

        imax=nford+1

  130   iavg=(imin+imax)/2

        IF(kford(iavg).GT.kfa) THEN

          imax=iavg

          IF(imax.GT.imin+1) goto 130

        ELSEIF(kford(iavg).LT.kfa) THEN

          imin=iavg

          IF(imax.GT.imin+1) goto 130

        ELSE

          pycomp=kcord(iavg)

        ENDIF

      ENDIF


C...Check if antiparticle allowed.

      IF(pycomp.NE.0.AND.kf.LT.0) THEN

        IF(kchg(pycomp,3).EQ.0) pycomp=0

      ENDIF


C...Save codes for possible future fast action.

      kflast=kf

      kclast=pycomp


      RETURN

      END


C*********************************************************************


C...PYERRM

C...Informs user of errors in program execution.


      SUBROUTINE pyerrm(MERR,CHMESS)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pyjets/,/pydat1/

C...Local character variable.

      CHARACTER chmess*(*)


C...Write first few warnings, then be silent.

      IF(merr.LE.10) THEN

        mstu(27)=mstu(27)+1

        mstu(28)=merr

        IF(mstu(25).EQ.1.AND.mstu(27).LE.mstu(26)) WRITE(mstu(11),5000)

     &  merr,mstu(31),chmess


C...Write first few errors, then be silent or stop program.

      ELSEIF(merr.LE.20) THEN

        mstu(23)=mstu(23)+1

        mstu(24)=merr-10

        IF(mstu(21).GE.1.AND.mstu(23).LE.mstu(22)) WRITE(mstu(11),5100)

     &  merr-10,mstu(31),chmess

        IF(mstu(21).GE.2.AND.mstu(23).GT.mstu(22)) THEN

          WRITE(mstu(11),5100) merr-10,mstu(31),chmess

          WRITE(mstu(11),5100) merr-10,mstu(31),chmess

          WRITE(mstu(11),5100) merr-10,mstu(31),chmess

          WRITE(mstu(11),5200)

          IF(merr.NE.17) CALL pylist(2)

          IF(merr.NE.17) CALL pylist(2)

          IF(merr.NE.17) CALL pylist(2)

      WRITE(6,*)' J.R. programme continuing without stop'

C         STOP

        ENDIF


C...Stop program in case of irreparable error.

      ELSE

        WRITE(mstu(11),5300) merr-20,mstu(31),chmess

        stop

      ENDIF


C...Formats for output.

 5000 FORMAT(/5x,'Advisory warning type',i2,' given after',i9,

     &' PYEXEC calls:'/5x,a)

 5100 FORMAT(/5x,'Error type',i2,' has occured after',i9,

     &' PYEXEC calls:'/5x,a)

 5200 FORMAT(5x,'Execution will be stopped after listing of last ',

     &'event!')

 5300 FORMAT(/5x,'Fatal error type',i2,' has occured after',i9,

     &' PYEXEC calls:'/5x,a/5x,'Execution will now be stopped!')


      RETURN

      END


C*********************************************************************


C...PYALEM

C...Calculates the running alpha_electromagnetic.


      FUNCTION pyalem(Q2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


C...Calculate real part of photon vacuum polarization.

C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.

C...For hadrons use parametrization of H. Burkhardt et al.

C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.

      aempi=paru(101)/(3d0*paru(1))

      IF(mstu(101).LE.0.OR.q2.LT.2d-6) THEN

        rpigg=0d0

      ELSEIF(mstu(101).EQ.2.AND.q2.LT.paru(104)) THEN

        rpigg=0d0

      ELSEIF(mstu(101).EQ.2) THEN

        rpigg=1d0-paru(101)/paru(103)

      ELSEIF(q2.LT.0.09d0) THEN

        rpigg=aempi*(13.4916d0+log(q2))+0.00835d0*log(1d0+q2)

      ELSEIF(q2.LT.9d0) THEN

        rpigg=aempi*(16.3200d0+2d0*log(q2))+

     &  0.00238d0*log(1d0+3.927d0*q2)

      ELSEIF(q2.LT.1d4) THEN

        rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00165d0+

     &  0.00299d0*log(1d0+q2)

      ELSE

        rpigg=aempi*(13.4955d0+3d0*log(q2))+0.00221d0+

     &  0.00293d0*log(1d0+q2)

      ENDIF


C...Calculate running alpha_em.

      pyalem=paru(101)/(1d0-rpigg)

      paru(108)=pyalem


      RETURN

      END


C*********************************************************************


C...PYALPS

C...Gives the value of alpha_strong.


      FUNCTION pyalps(Q2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Constant alpha_strong trivial.

      IF(mstu(111).LE.0) THEN

        pyalps=paru(111)

        mstu(118)=mstu(112)

        paru(117)=0d0

        paru(118)=paru(111)

        RETURN

      ENDIF


C...Find effective Q2, number of flavours and Lambda.

      q2eff=q2

      IF(mstu(115).GE.2) q2eff=max(q2,paru(114))

      nf=mstu(112)

      alam2=paru(112)**2

  100 IF(nf.GT.max(2,mstu(113))) THEN

        q2thr=paru(113)*pmas(nf,1)**2

        IF(q2eff.LT.q2thr) THEN

          nf=nf-1

          alam2=alam2*(q2thr/alam2)**(2d0/(33d0-2d0*nf))

          goto 100

        ENDIF

      ENDIF

  110 IF(nf.LT.min(8,mstu(114))) THEN

        q2thr=paru(113)*pmas(nf+1,1)**2

        IF(q2eff.GT.q2thr) THEN

          nf=nf+1

          alam2=alam2*(alam2/q2thr)**(2d0/(33d0-2d0*nf))

          goto 110

        ENDIF

      ENDIF

      IF(mstu(115).EQ.1) q2eff=q2eff+alam2

      paru(117)=sqrt(alam2)


C...Evaluate first or second order alpha_strong.

      b0=(33d0-2d0*nf)/6d0

      algq=log(max(1.0001d0,q2eff/alam2))

      IF(mstu(111).EQ.1) THEN

        pyalps=min(paru(115),paru(2)/(b0*algq))

      ELSE

        b1=(153d0-19d0*nf)/6d0

        pyalps=min(paru(115),paru(2)/(b0*algq)*(1d0-b1*log(algq)/

     &  (b0**2*algq)))

      ENDIF

      mstu(118)=nf

      paru(118)=pyalps


      RETURN

      END


C*********************************************************************


C...PYANGL

C...Reconstructs an angle from given x and y coordinates.


      FUNCTION pyangl(X,Y)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


      pyangl=0d0

      r=sqrt(x**2+y**2)

      IF(r.LT.1d-20) RETURN

      IF(abs(x)/r.LT.0.8d0) THEN

        pyangl=sign(acos(x/r),y)

      ELSE

        pyangl=asin(y/r)

        IF(x.LT.0d0.AND.pyangl.GE.0d0) THEN

          pyangl=paru(1)-pyangl

        ELSEIF(x.LT.0d0) THEN

          pyangl=-paru(1)-pyangl

        ENDIF

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYR

C...Generates random numbers uniformly distributed between

C...0 and 1, excluding the endpoints.


      FUNCTION pyr(IDUMMY)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydatr/mrpy(6),rrpy(100)

      SAVE /pydatr/

C...Equivalence between commonblock and local variables.

      equivalence(mrpy1,mrpy(1)),(mrpy2,mrpy(2)),(mrpy3,mrpy(3)),

     &(mrpy4,mrpy(4)),(mrpy5,mrpy(5)),(mrpy6,mrpy(6)),

     &(rrpy98,rrpy(98)),(rrpy99,rrpy(99)),(rrpy00,rrpy(100))


C...Initialize generation from given seed.

      IF(mrpy2.EQ.0) THEN

        ij=mod(mrpy1/30082,31329)

        kl=mod(mrpy1,30082)

        i=mod(ij/177,177)+2

        j=mod(ij,177)+2

        k=mod(kl/169,178)+1

        l=mod(kl,169)

        DO 110 ii=1,97

          s=0d0

          t=0.5d0

          DO 100 jj=1,48

            m=mod(mod(i*j,179)*k,179)

            i=j

            j=k

            k=m

            l=mod(53*l+1,169)

            IF(mod(l*m,64).GE.32) s=s+t

            t=0.5d0*t

  100     CONTINUE

          rrpy(ii)=s

  110   CONTINUE

        twom24=1d0

        DO 120 i24=1,24

          twom24=0.5d0*twom24

  120   CONTINUE

        rrpy98=362436d0*twom24

        rrpy99=7654321d0*twom24

        rrpy00=16777213d0*twom24

        mrpy2=1

        mrpy3=0

        mrpy4=97

        mrpy5=33

      ENDIF


C...Generate next random number.

  130 runi=rrpy(mrpy4)-rrpy(mrpy5)

      IF(runi.LT.0d0) runi=runi+1d0

      rrpy(mrpy4)=runi

      mrpy4=mrpy4-1

      IF(mrpy4.EQ.0) mrpy4=97

      mrpy5=mrpy5-1

      IF(mrpy5.EQ.0) mrpy5=97

      rrpy98=rrpy98-rrpy99

      IF(rrpy98.LT.0d0) rrpy98=rrpy98+rrpy00

      runi=runi-rrpy98

      IF(runi.LT.0d0) runi=runi+1d0

      IF(runi.LE.0d0.OR.runi.GE.1d0) goto 130


C...Update counters. Random number to output.

      mrpy3=mrpy3+1

      IF(mrpy3.EQ.1000000000) THEN

        mrpy2=mrpy2+1

        mrpy3=0

      ENDIF

      pyr=runi


      RETURN

      END


C*********************************************************************


C...PYRGET

C...Dumps the state of the random number generator on a file

C...for subsequent startup from this state onwards.


      SUBROUTINE pyrget(LFN,MOVE)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydatr/mrpy(6),rrpy(100)

      SAVE /pydatr/

C...Local character variable.

      CHARACTER cherr*8


C...Backspace required number of records (or as many as there are).

      IF(move.LT.0) THEN

        nbck=min(mrpy(6),-move)

        DO 100 ibck=1,nbck

          backspace(lfn,err=110,iostat=ierr)

  100   CONTINUE

        mrpy(6)=mrpy(6)-nbck

      ENDIF


C...Unformatted write on unit LFN.

      WRITE(lfn,err=110,iostat=ierr) (mrpy(i1),i1=1,5),

     &(rrpy(i2),i2=1,100)

      mrpy(6)=mrpy(6)+1

      RETURN


C...Write error.

  110 WRITE(cherr,'(I8)') ierr

      CALL pyerrm(18,'(PYRGET:) error when accessing file, IOSTAT ='//

     &cherr)


      RETURN

      END


C*********************************************************************


C...PYRSET

C...Reads a state of the random number generator from a file

C...for subsequent generation from this state onwards.


      SUBROUTINE pyrset(LFN,MOVE)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydatr/mrpy(6),rrpy(100)

      SAVE /pydatr/

C...Local character variable.

      CHARACTER cherr*8


C...Backspace required number of records (or as many as there are).

      IF(move.LT.0) THEN

        nbck=min(mrpy(6),-move)

        DO 100 ibck=1,nbck

          backspace(lfn,err=120,iostat=ierr)

  100   CONTINUE

        mrpy(6)=mrpy(6)-nbck

      ENDIF


C...Unformatted read from unit LFN.

      nfor=1+max(0,move)

      DO 110 ifor=1,nfor

        READ(lfn,err=120,iostat=ierr) (mrpy(i1),i1=1,5),

     &  (rrpy(i2),i2=1,100)

  110 CONTINUE

      mrpy(6)=mrpy(6)+nfor

      RETURN


C...Write error.

  120 WRITE(cherr,'(I8)') ierr

      CALL pyerrm(18,'(PYRSET:) error when accessing file, IOSTAT ='//

     &cherr)


      RETURN

      END


C*********************************************************************


C...PYROBO

C...Performs rotations and boosts.


      SUBROUTINE pyrobo(IMI,IMA,THE,PHI,BEX,BEY,BEZ)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pyjets/,/pydat1/

C...Local arrays.

      dimension rot(3,3),pr(3),vr(3),dp(4),dv(4)


C...Find and check range of rotation/boost.

      imin=imi

      IF(imin.LE.0) imin=1

      IF(mstu(1).GT.0) imin=mstu(1)

      imax=ima

      IF(imax.LE.0) imax=n

      IF(mstu(2).GT.0) imax=mstu(2)

      IF(imin.GT.mstu(4).OR.imax.GT.mstu(4)) THEN

        CALL pyerrm(11,'(PYROBO:) range outside PYJETS memory')

        RETURN

      ENDIF


C...Optional resetting of V (when not set before.)

      IF(mstu(33).NE.0) THEN

        DO 110 i=min(imin,mstu(4)),min(imax,mstu(4))

          DO 100 j=1,5

            v(i,j)=0d0

  100     CONTINUE

  110   CONTINUE

        mstu(33)=0

      ENDIF


C...Rotate, typically from z axis to direction (theta,phi).

      IF(the**2+phi**2.GT.1d-20) THEN

        rot(1,1)=cos(the)*cos(phi)

        rot(1,2)=-sin(phi)

        rot(1,3)=sin(the)*cos(phi)

        rot(2,1)=cos(the)*sin(phi)

        rot(2,2)=cos(phi)

        rot(2,3)=sin(the)*sin(phi)

        rot(3,1)=-sin(the)

        rot(3,2)=0d0

        rot(3,3)=cos(the)

        DO 140 i=imin,imax

          IF(k(i,1).LE.0) goto 140

          DO 120 j=1,3

            pr(j)=p(i,j)

            vr(j)=v(i,j)

  120     CONTINUE

          DO 130 j=1,3

            p(i,j)=rot(j,1)*pr(1)+rot(j,2)*pr(2)+rot(j,3)*pr(3)

            v(i,j)=rot(j,1)*vr(1)+rot(j,2)*vr(2)+rot(j,3)*vr(3)

  130     CONTINUE

  140   CONTINUE

      ENDIF


C...Boost, typically from rest to momentum/energy=beta.

      IF(bex**2+bey**2+bez**2.GT.1d-20) THEN

        dbx=bex

        dby=bey

        dbz=bez

        db=sqrt(dbx**2+dby**2+dbz**2)

        eps1=1d0-1d-12

        IF(db.GT.eps1) THEN

C...Rescale boost vector if too close to unity.

          CALL pyerrm(3,'(PYROBO:) boost vector too large')

          dbx=dbx*(eps1/db)

          dby=dby*(eps1/db)

          dbz=dbz*(eps1/db)

          db=eps1

        ENDIF

        dga=1d0/sqrt(1d0-db**2)

        DO 160 i=imin,imax

          IF(k(i,1).LE.0) goto 160

          DO 150 j=1,4

            dp(j)=p(i,j)

            dv(j)=v(i,j)

  150     CONTINUE

          dbp=dbx*dp(1)+dby*dp(2)+dbz*dp(3)

          dgabp=dga*(dga*dbp/(1d0+dga)+dp(4))

          p(i,1)=dp(1)+dgabp*dbx

          p(i,2)=dp(2)+dgabp*dby

          p(i,3)=dp(3)+dgabp*dbz

          p(i,4)=dga*(dp(4)+dbp)

          dbv=dbx*dv(1)+dby*dv(2)+dbz*dv(3)

          dgabv=dga*(dga*dbv/(1d0+dga)+dv(4))

          v(i,1)=dv(1)+dgabv*dbx

          v(i,2)=dv(2)+dgabv*dby

          v(i,3)=dv(3)+dgabv*dbz

          v(i,4)=dga*(dv(4)+dbv)

  160   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYEDIT

C...Performs global manipulations on the event record, in particular

C...to exclude unstable or undetectable partons/particles.


      SUBROUTINE pyedit(MEDIT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension ns(2),pts(2),pls(2)


C...Remove unwanted partons/particles.

      IF((medit.GE.0.AND.medit.LE.3).OR.medit.EQ.5) THEN

        imax=n

        IF(mstu(2).GT.0) imax=mstu(2)

        i1=max(1,mstu(1))-1

        DO 110 i=max(1,mstu(1)),imax

          IF(k(i,1).EQ.0.OR.k(i,1).GT.20) goto 110

          IF(medit.EQ.1) THEN

            IF(k(i,1).GT.10) goto 110

          ELSEIF(medit.EQ.2) THEN

            IF(k(i,1).GT.10) goto 110

            kc=pycomp(k(i,2))

            IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.kc.EQ.18)

     &      goto 110

          ELSEIF(medit.EQ.3) THEN

            IF(k(i,1).GT.10) goto 110

            kc=pycomp(k(i,2))

            IF(kc.EQ.0) goto 110

            IF(kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0) goto 110

          ELSEIF(medit.EQ.5) THEN

            IF(k(i,1).EQ.13.OR.k(i,1).EQ.14) goto 110

            kc=pycomp(k(i,2))

            IF(kc.EQ.0) goto 110

            IF(k(i,1).GE.11.AND.kchg(kc,2).EQ.0) goto 110

          ENDIF


C...Pack remaining partons/particles. Origin no longer known.

          i1=i1+1

          DO 100 j=1,5

            k(i1,j)=k(i,j)

            p(i1,j)=p(i,j)

            v(i1,j)=v(i,j)

  100     CONTINUE

          k(i1,3)=0

  110   CONTINUE

        IF(i1.LT.n) mstu(3)=0

        IF(i1.LT.n) mstu(70)=0

        n=i1


C...Selective removal of class of entries. New position of retained.

      ELSEIF(medit.GE.11.AND.medit.LE.15) THEN

        i1=0

        DO 120 i=1,n

          k(i,3)=mod(k(i,3),mstu(5))

          IF(medit.EQ.11.AND.k(i,1).LT.0) goto 120

          IF(medit.EQ.12.AND.k(i,1).EQ.0) goto 120

          IF(medit.EQ.13.AND.(k(i,1).EQ.11.OR.k(i,1).EQ.12.OR.

     &    k(i,1).EQ.15).AND.k(i,2).NE.94) goto 120

          IF(medit.EQ.14.AND.(k(i,1).EQ.13.OR.k(i,1).EQ.14.OR.

     &    k(i,2).EQ.94)) goto 120

          IF(medit.EQ.15.AND.k(i,1).GE.21) goto 120

          i1=i1+1

          k(i,3)=k(i,3)+mstu(5)*i1

  120   CONTINUE


C...Find new event history information and replace old.

        DO 140 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,3)/mstu(5).EQ.0)

     &    goto 140

          id=i

  130     im=mod(k(id,3),mstu(5))

          IF(medit.EQ.13.AND.im.GT.0.AND.im.LE.n) THEN

            IF((k(im,1).EQ.11.OR.k(im,1).EQ.12.OR.k(im,1).EQ.15).AND.

     &      k(im,2).NE.94) THEN

              id=im

              goto 130

            ENDIF

          ELSEIF(medit.EQ.14.AND.im.GT.0.AND.im.LE.n) THEN

            IF(k(im,1).EQ.13.OR.k(im,1).EQ.14.OR.k(im,2).EQ.94) THEN

              id=im

              goto 130

            ENDIF

          ENDIF

          k(i,3)=mstu(5)*(k(i,3)/mstu(5))

          IF(im.NE.0) k(i,3)=k(i,3)+k(im,3)/mstu(5)

          IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) THEN

            IF(k(i,4).GT.0.AND.k(i,4).LE.mstu(4)) k(i,4)=

     &      k(k(i,4),3)/mstu(5)

            IF(k(i,5).GT.0.AND.k(i,5).LE.mstu(4)) k(i,5)=

     &      k(k(i,5),3)/mstu(5)

          ELSE

            kcm=mod(k(i,4)/mstu(5),mstu(5))

            IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)

            kcd=mod(k(i,4),mstu(5))

            IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)

            k(i,4)=mstu(5)**2*(k(i,4)/mstu(5)**2)+mstu(5)*kcm+kcd

            kcm=mod(k(i,5)/mstu(5),mstu(5))

            IF(kcm.GT.0.AND.kcm.LE.mstu(4)) kcm=k(kcm,3)/mstu(5)

            kcd=mod(k(i,5),mstu(5))

            IF(kcd.GT.0.AND.kcd.LE.mstu(4)) kcd=k(kcd,3)/mstu(5)

            k(i,5)=mstu(5)**2*(k(i,5)/mstu(5)**2)+mstu(5)*kcm+kcd

          ENDIF

  140   CONTINUE


C...Pack remaining entries.

        i1=0

        mstu90=mstu(90)

        mstu(90)=0

        DO 170 i=1,n

          IF(k(i,3)/mstu(5).EQ.0) goto 170

          i1=i1+1

          DO 150 j=1,5

            k(i1,j)=k(i,j)

            p(i1,j)=p(i,j)

            v(i1,j)=v(i,j)

  150     CONTINUE

          k(i1,3)=mod(k(i1,3),mstu(5))

          DO 160 iz=1,mstu90

            IF(i.EQ.mstu(90+iz)) THEN

              mstu(90)=mstu(90)+1

              mstu(90+mstu(90))=i1

              paru(90+mstu(90))=paru(90+iz)

            ENDIF

  160     CONTINUE

  170   CONTINUE

        IF(i1.LT.n) mstu(3)=0

        IF(i1.LT.n) mstu(70)=0

        n=i1


C...Fill in some missing daughter pointers (lost in colour flow).

      ELSEIF(medit.EQ.16) THEN

        DO 220 i=1,n

          IF(k(i,1).LE.10.OR.k(i,1).GT.20) goto 220

          IF(k(i,4).NE.0.OR.k(i,5).NE.0) goto 220

C...Find daughters who point to mother.

          DO 180 i1=i+1,n

            IF(k(i1,3).NE.i) THEN

            ELSEIF(k(i,4).EQ.0) THEN

              k(i,4)=i1

            ELSE

              k(i,5)=i1

            ENDIF

  180     CONTINUE

          IF(k(i,5).EQ.0) k(i,5)=k(i,4)

          IF(k(i,4).NE.0) goto 220

C...Find daughters who point to documentation version of mother.

          im=k(i,3)

          IF(im.LE.0.OR.im.GE.i) goto 220

          IF(k(im,1).LE.20.OR.k(im,1).GT.30) goto 220

          IF(k(im,2).NE.k(i,2).OR.abs(p(im,5)-p(i,5)).GT.1d-2) goto 220

          DO 190 i1=i+1,n

            IF(k(i1,3).NE.im) THEN

            ELSEIF(k(i,4).EQ.0) THEN

              k(i,4)=i1

            ELSE

              k(i,5)=i1

            ENDIF

  190     CONTINUE

          IF(k(i,5).EQ.0) k(i,5)=k(i,4)

          IF(k(i,4).NE.0) goto 220

C...Find daughters who point to documentation daughters who,

C...in their turn, point to documentation mother.

          id1=im

          id2=im

          DO 200 i1=im+1,i-1

            IF(k(i1,3).EQ.im.AND.k(i1,1).GT.20.AND.k(i1,1).LE.30) THEN

              id2=i1

              IF(id1.EQ.im) id1=i1

            ENDIF

  200     CONTINUE

          DO 210 i1=i+1,n

            IF(k(i1,3).NE.id1.AND.k(i1,3).NE.id2) THEN

            ELSEIF(k(i,4).EQ.0) THEN

              k(i,4)=i1

            ELSE

              k(i,5)=i1

            ENDIF

  210     CONTINUE

          IF(k(i,5).EQ.0) k(i,5)=k(i,4)

  220   CONTINUE


C...Save top entries at bottom of PYJETS commonblock.

      ELSEIF(medit.EQ.21) THEN

        IF(2*n.GE.mstu(4)) THEN

          CALL pyerrm(11,'(PYEDIT:) no more memory left in PYJETS')

          RETURN

        ENDIF

        DO 240 i=1,n

          DO 230 j=1,5

            k(mstu(4)-i,j)=k(i,j)

            p(mstu(4)-i,j)=p(i,j)

            v(mstu(4)-i,j)=v(i,j)

  230     CONTINUE

  240   CONTINUE

        mstu(32)=n


C...Restore bottom entries of commonblock PYJETS to top.

      ELSEIF(medit.EQ.22) THEN

        DO 260 i=1,mstu(32)

          DO 250 j=1,5

            k(i,j)=k(mstu(4)-i,j)

            p(i,j)=p(mstu(4)-i,j)

            v(i,j)=v(mstu(4)-i,j)

  250     CONTINUE

  260   CONTINUE

        n=mstu(32)


C...Mark primary entries at top of commonblock PYJETS as untreated.

      ELSEIF(medit.EQ.23) THEN

        i1=0

        DO 270 i=1,n

          kh=k(i,3)

          IF(kh.GE.1) THEN

            IF(k(kh,1).GT.20) kh=0

          ENDIF

          IF(kh.NE.0) goto 280

          i1=i1+1

          IF(k(i,1).GT.10.AND.k(i,1).LE.20) k(i,1)=k(i,1)-10

  270   CONTINUE

  280   n=i1


C...Place largest axis along z axis and second largest in xy plane.

      ELSEIF(medit.EQ.31.OR.medit.EQ.32) THEN

        CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61),1),

     &  p(mstu(61),2)),0d0,0d0,0d0)

        CALL pyrobo(1,n+mstu(3),-pyangl(p(mstu(61),3),

     &  p(mstu(61),1)),0d0,0d0,0d0,0d0)

        CALL pyrobo(1,n+mstu(3),0d0,-pyangl(p(mstu(61)+1,1),

     &  p(mstu(61)+1,2)),0d0,0d0,0d0)

        IF(medit.EQ.31) RETURN


C...Rotate to put slim jet along +z axis.

        DO 290 is=1,2

          ns(is)=0

          pts(is)=0d0

          pls(is)=0d0

  290   CONTINUE

        DO 300 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 300

          IF(mstu(41).GE.2) THEN

            kc=pycomp(k(i,2))

            IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &      kc.EQ.18) goto 300

            IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))

     &      .EQ.0) goto 300

          ENDIF

          is=2d0-sign(0.5d0,p(i,3))

          ns(is)=ns(is)+1

          pts(is)=pts(is)+sqrt(p(i,1)**2+p(i,2)**2)

  300   CONTINUE

        IF(ns(1)*pts(2)**2.LT.ns(2)*pts(1)**2)

     &  CALL pyrobo(1,n+mstu(3),paru(1),0d0,0d0,0d0,0d0)


C...Rotate to put second largest jet into -z,+x quadrant.

        DO 310 i=1,n

          IF(p(i,3).GE.0d0) goto 310

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 310

          IF(mstu(41).GE.2) THEN

            kc=pycomp(k(i,2))

            IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &      kc.EQ.18) goto 310

            IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2))

     &      .EQ.0) goto 310

          ENDIF

          is=2d0-sign(0.5d0,p(i,1))

          pls(is)=pls(is)-p(i,3)

  310   CONTINUE

        IF(pls(2).GT.pls(1)) CALL pyrobo(1,n+mstu(3),0d0,paru(1),

     &  0d0,0d0,0d0)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYLIST

C...Gives program heading, or lists an event, or particle

C...data, or current parameter values.


      SUBROUTINE pylist(MLIST)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter statement to help give large particle numbers.

      parameter(ksusy1=1000000,ksusy2=2000000,kexcit=4000000)

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/

C...Local arrays, character variables and data.

      CHARACTER chap*16,chac*16,chan*16,chad(5)*16,chdl(7)*4

      dimension ps(6)

      DATA chdl/'(())',' ','()','!!','<>','==','(==)'/


C...Initialization printout: version number and date of last change.

      IF(mlist.EQ.0.OR.mstu(12).EQ.1) THEN

        CALL pylogo

        mstu(12)=0

        IF(mlist.EQ.0) RETURN

      ENDIF


C...List event data, including additional lines after N.

      IF(mlist.GE.1.AND.mlist.LE.3) THEN

        IF(mlist.EQ.1) WRITE(mstu(11),5100)

        IF(mlist.EQ.2) WRITE(mstu(11),5200)

        IF(mlist.EQ.3) WRITE(mstu(11),5300)

        lmx=12

        IF(mlist.GE.2) lmx=16

        istr=0

        imax=n

        IF(mstu(2).GT.0) imax=mstu(2)

        DO 120 i=max(1,mstu(1)),max(imax,n+max(0,mstu(3)))

          IF((i.GT.imax.AND.i.LE.n).OR.k(i,1).LT.0) goto 120


C...Get particle name, pad it and check it is not too long.

          CALL pyname(k(i,2),chap)

          len=0

          DO 100 lem=1,16

            IF(chap(lem:lem).NE.' ') len=lem

  100     CONTINUE

          mdl=(k(i,1)+19)/10

          ldl=0

          IF(mdl.EQ.2.OR.mdl.GE.8) THEN

            chac=chap

            IF(len.GT.lmx) chac(lmx:lmx)='?'

          ELSE

            ldl=1

            IF(mdl.EQ.1.OR.mdl.EQ.7) ldl=2

            IF(len.EQ.0) THEN

              chac=chdl(mdl)(1:2*ldl)//' '

            ELSE

              chac=chdl(mdl)(1:ldl)//chap(1:min(len,lmx-2*ldl))//

     &        chdl(mdl)(ldl+1:2*ldl)//' '

              IF(len+2*ldl.GT.lmx) chac(lmx:lmx)='?'

            ENDIF

          ENDIF


C...Add information on string connection.

          IF(k(i,1).EQ.1.OR.k(i,1).EQ.2.OR.k(i,1).EQ.11.OR.k(i,1).EQ.12)

     &    THEN

            kc=pycomp(k(i,2))

            kcc=0

            IF(kc.NE.0) kcc=kchg(kc,2)

            IF(iabs(k(i,2)).EQ.39) THEN

              IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='X'

            ELSEIF(kcc.NE.0.AND.istr.EQ.0) THEN

              istr=1

              IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='A'

            ELSEIF(kcc.NE.0.AND.(k(i,1).EQ.2.OR.k(i,1).EQ.12)) THEN

              IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='I'

            ELSEIF(kcc.NE.0) THEN

              istr=0

              IF(len+2*ldl+3.LE.lmx) chac(lmx-1:lmx-1)='V'

            ENDIF

          ENDIF


C...Write data for particle/jet.

          IF(mlist.EQ.1.AND.abs(p(i,4)).LT.9999d0) THEN

            WRITE(mstu(11),5400) i,chac(1:12),(k(i,j1),j1=1,3),

     &      (p(i,j2),j2=1,5)

          ELSEIF(mlist.EQ.1.AND.abs(p(i,4)).LT.99999d0) THEN

            WRITE(mstu(11),5500) i,chac(1:12),(k(i,j1),j1=1,3),

     &      (p(i,j2),j2=1,5)

          ELSEIF(mlist.EQ.1) THEN

            WRITE(mstu(11),5600) i,chac(1:12),(k(i,j1),j1=1,3),

     &      (p(i,j2),j2=1,5)

          ELSEIF(mstu(5).EQ.10000.AND.(k(i,1).EQ.3.OR.k(i,1).EQ.13.OR.

     &      k(i,1).EQ.14)) THEN

            WRITE(mstu(11),5700) i,chac,(k(i,j1),j1=1,3),

     &      k(i,4)/100000000,mod(k(i,4)/10000,10000),mod(k(i,4),10000),

     &      k(i,5)/100000000,mod(k(i,5)/10000,10000),mod(k(i,5),10000),

     &      (p(i,j2),j2=1,5)

          ELSE

            WRITE(mstu(11),5800) i,chac,(k(i,j1),j1=1,5),

     &      (p(i,j2),j2=1,5)

          ENDIF

          IF(mlist.EQ.3) WRITE(mstu(11),5900) (v(i,j),j=1,5)


C...Insert extra separator lines specified by user.

          IF(mstu(70).GE.1) THEN

            isep=0

            DO 110 j=1,min(10,mstu(70))

              IF(i.EQ.mstu(70+j)) isep=1

  110       CONTINUE

            IF(isep.EQ.1.AND.mlist.EQ.1) WRITE(mstu(11),6000)

            IF(isep.EQ.1.AND.mlist.GE.2) WRITE(mstu(11),6100)

          ENDIF

  120   CONTINUE


C...Sum of charges and momenta.

        DO 130 j=1,6

          ps(j)=pyp(0,j)

  130   CONTINUE

        IF(mlist.EQ.1.AND.abs(ps(4)).LT.9999d0) THEN

          WRITE(mstu(11),6200) ps(6),(ps(j),j=1,5)

        ELSEIF(mlist.EQ.1.AND.abs(ps(4)).LT.99999d0) THEN

          WRITE(mstu(11),6300) ps(6),(ps(j),j=1,5)

        ELSEIF(mlist.EQ.1) THEN

          WRITE(mstu(11),6400) ps(6),(ps(j),j=1,5)

        ELSE

          WRITE(mstu(11),6500) ps(6),(ps(j),j=1,5)

        ENDIF


C...Give simple list of KF codes defined in program.

      ELSEIF(mlist.EQ.11) THEN

        WRITE(mstu(11),6600)

        DO 140 kf=1,80

          CALL pyname(kf,chap)

          CALL pyname(-kf,chan)

          IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap

          IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan

  140   CONTINUE

        DO 170 kfls=1,3,2

          DO 160 kfla=1,5

            DO 150 kflb=1,kfla-(3-kfls)/2

              kf=1000*kfla+100*kflb+kfls

              CALL pyname(kf,chap)

              CALL pyname(-kf,chan)

              WRITE(mstu(11),6700) kf,chap,-kf,chan

  150       CONTINUE

  160     CONTINUE

  170   CONTINUE

        kf=130

        CALL pyname(kf,chap)

        WRITE(mstu(11),6700) kf,chap

        kf=310

        CALL pyname(kf,chap)

        WRITE(mstu(11),6700) kf,chap

        DO 200 kmul=0,5

          kfls=3

          IF(kmul.EQ.0.OR.kmul.EQ.3) kfls=1

          IF(kmul.EQ.5) kfls=5

          kflr=0

          IF(kmul.EQ.2.OR.kmul.EQ.3) kflr=1

          IF(kmul.EQ.4) kflr=2

          DO 190 kflb=1,5

            DO 180 kflc=1,kflb-1

              kf=10000*kflr+100*kflb+10*kflc+kfls

              CALL pyname(kf,chap)

              CALL pyname(-kf,chan)

              WRITE(mstu(11),6700) kf,chap,-kf,chan

  180       CONTINUE

            kf=10000*kflr+110*kflb+kfls

            CALL pyname(kf,chap)

            WRITE(mstu(11),6700) kf,chap

  190     CONTINUE

  200   CONTINUE

        kf=100443

        CALL pyname(kf,chap)

        WRITE(mstu(11),6700) kf,chap

        kf=100553

        CALL pyname(kf,chap)

        WRITE(mstu(11),6700) kf,chap

        DO 240 kflsp=1,3

          kfls=2+2*(kflsp/3)

          DO 230 kfla=1,5

            DO 220 kflb=1,kfla

              DO 210 kflc=1,kflb

                IF(kflsp.EQ.1.AND.(kfla.EQ.kflb.OR.kflb.EQ.kflc))

     &          goto 210

                IF(kflsp.EQ.2.AND.kfla.EQ.kflc) goto 210

                IF(kflsp.EQ.1) kf=1000*kfla+100*kflc+10*kflb+kfls

                IF(kflsp.GE.2) kf=1000*kfla+100*kflb+10*kflc+kfls

                CALL pyname(kf,chap)

                CALL pyname(-kf,chan)

                WRITE(mstu(11),6700) kf,chap,-kf,chan

  210         CONTINUE

  220       CONTINUE

  230     CONTINUE

  240   CONTINUE

        DO 250 kf=ksusy1+1,ksusy1+40

          CALL pyname(kf,chap)

          CALL pyname(-kf,chan)

          IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap

          IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan

  250   CONTINUE

        DO 260 kf=ksusy2+1,ksusy2+40

          CALL pyname(kf,chap)

          CALL pyname(-kf,chan)

          IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap

          IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan

  260   CONTINUE

        DO 270 kf=kexcit+1,kexcit+40

          CALL pyname(kf,chap)

          CALL pyname(-kf,chan)

          IF(chap.NE.' '.AND.chan.EQ.' ') WRITE(mstu(11),6700) kf,chap

          IF(chan.NE.' ') WRITE(mstu(11),6700) kf,chap,-kf,chan

  270   CONTINUE


C...List parton/particle data table. Check whether to be listed.

      ELSEIF(mlist.EQ.12) THEN

        WRITE(mstu(11),6800)

        DO 300 kc=1,mstu(6)

          kf=kchg(kc,4)

          IF(kf.EQ.0) goto 300

          IF(kf.LT.mstu(1).OR.(mstu(2).GT.0.AND.kf.GT.mstu(2)))

     &    goto 300


C...Find particle name and mass. Print information.

          CALL pyname(kf,chap)

          IF(kf.LE.100.AND.chap.EQ.' '.AND.mdcy(kc,2).EQ.0) goto 300

          CALL pyname(-kf,chan)

          WRITE(mstu(11),6900) kf,kc,chap,chan,(kchg(kc,j1),j1=1,3),

     &    (pmas(kc,j2),j2=1,4),mdcy(kc,1)


C...Particle decay: channel number, branching ratios, matrix element,

C...decay products.

          DO 290 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1

            DO 280 j=1,5

              CALL pyname(kfdp(idc,j),chad(j))

  280       CONTINUE

            WRITE(mstu(11),7000) idc,mdme(idc,1),mdme(idc,2),brat(idc),

     &      (chad(j),j=1,5)

  290     CONTINUE

  300   CONTINUE


C...List parameter value table.

      ELSEIF(mlist.EQ.13) THEN

        WRITE(mstu(11),7100)

        DO 310 i=1,200

          WRITE(mstu(11),7200) i,mstu(i),paru(i),mstj(i),parj(i),parf(i)

  310   CONTINUE

      ENDIF


C...Format statements for output on unit MSTU(11) (by default 6).

 5100 FORMAT(///28x,'Event listing (summary)'//4x,'I particle/jet KS',

     &5x,'KF  orig    p_x      p_y      p_z       E        m'/)

 5200 FORMAT(///28x,'Event listing (standard)'//4x,'I  particle/jet',

     &'  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',

     &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/)

 5300 FORMAT(///28x,'Event listing (with vertices)'//4x,'I  particle/j',

     &'et  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)       P(I,1)',

     &'       P(I,2)       P(I,3)       P(I,4)       P(I,5)'/73x,

     &'V(I,1)       V(I,2)       V(I,3)       V(I,4)       V(I,5)'/)

 5400 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.3)

 5500 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.2)

 5600 FORMAT(1x,i4,1x,a12,1x,i2,i8,1x,i4,5f9.1)

 5700 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i1,2i4),5f13.5)

 5800 FORMAT(1x,i4,2x,a16,1x,i3,1x,i9,1x,i4,2(3x,i9),5f13.5)

 5900 FORMAT(66x,5(1x,f12.3))

 6000 FORMAT(1x,78('='))

 6100 FORMAT(1x,130('='))

 6200 FORMAT(19x,'sum:',f6.2,5x,5f9.3)

 6300 FORMAT(19x,'sum:',f6.2,5x,5f9.2)

 6400 FORMAT(19x,'sum:',f6.2,5x,5f9.1)

 6500 FORMAT(19x,'sum charge:',f6.2,3x,'sum momentum and inv. mass:',

     &5f13.5)

 6600 FORMAT(///20x,'List of KF codes in program'/)

 6700 FORMAT(4x,i9,4x,a16,6x,i9,4x,a16)

 6800 FORMAT(///30x,'Particle/parton data table'//8x,'KF',5x,'KC',4x,

     &'particle',8x,'antiparticle',6x,'chg  col  anti',8x,'mass',7x,

     &'width',7x,'w-cut',5x,'lifetime',1x,'decay'/11x,'IDC',1x,'on/off',

     &1x,'ME',3x,'Br.rat.',4x,'decay products')

 6900 FORMAT(/1x,i9,3x,i4,4x,a16,a16,3i5,1x,f12.5,2(1x,f11.5),

     &1x,1p,e13.5,3x,i2)

 7000 FORMAT(10x,i4,2x,i3,2x,i3,2x,f10.6,4x,5a16)

 7100 FORMAT(///20x,'Parameter value table'//4x,'I',3x,'MSTU(I)',

     &8x,'PARU(I)',3x,'MSTJ(I)',8x,'PARJ(I)',8x,'PARF(I)')

 7200 FORMAT(1x,i4,1x,i9,1x,f14.5,1x,i9,1x,f14.5,1x,f14.5)


      RETURN

      END


C*********************************************************************


C...PYLOGO

C...Writes a logo for the program.


      SUBROUTINE pylogo


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Parameter for length of information block.

      parameter(irefer=17)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pypars/mstp(200),parp(200),msti(200),pari(200)

      SAVE /pydat1/,/pypars/

C...Local arrays and character variables.

      INTEGER idati(6)

      CHARACTER month(12)*3, logo(48)*32, refer(2*irefer)*36, line*79,

     &vers*1, subv*3, date*2, year*4, hour*2, minu*2, seco*2


C...Data on months, logo, titles, and references.

      DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',

     &'Oct','Nov','Dec'/

      DATA (logo(j),j=1,19)/

     &'            *......*            ',

     &'       *:::!!:::::::::::*       ',

     &'    *::::::!!::::::::::::::*    ',

     &'  *::::::::!!::::::::::::::::*  ',

     &' *:::::::::!!:::::::::::::::::* ',

     &' *:::::::::!!:::::::::::::::::* ',

     &'  *::::::::!!::::::::::::::::*! ',

     &'    *::::::!!::::::::::::::* !! ',

     &'    !! *:::!!:::::::::::*    !! ',

     &'    !!     !* -><- *         !! ',

     &'    !!     !!                !! ',

     &'    !!     !!                !! ',

     &'    !!                       !! ',

     &'    !!        ep             !! ',

     &'    !!                       !! ',

     &'    !!                 pp    !! ',

     &'    !!   e+e-                !! ',

     &'    !!                       !! ',

     &'    !!                          '/

      DATA (logo(j),j=20,38)/

     &'Welcome to the Lund Monte Carlo!',

     &'                                ',

     &'PPP  Y   Y TTTTT H   H III   A  ',

     &'P  P  Y Y    T   H   H  I   A A ',

     &'PPP    Y     T   HHHHH  I  AAAAA',

     &'P      Y     T   H   H  I  A   A',

     &'P      Y     T   H   H III A   A',

     &'                                ',

     &'This is PYTHIA version x.xxx    ',

     &'Last date of change: xx xxx 199x',

     &'                                ',

     &'Now is xx xxx 199x at xx:xx:xx  ',

     &'                                ',

     &'Disclaimer: this program comes  ',

     &'without any guarantees. Beware  ',

     &'of errors and use common sense  ',

     &'when interpreting results.      ',

     &'                                ',

     &'Copyright T. Sjostrand (1997)   '/

      DATA (refer(j),j=1,18)/

     &'An archive of program versions and d',

     &'ocumentation is found on the web:   ',

     &'http://thep.lu.se/tf2/staff/torbjorn',

     &'/Pythia.html                        ',

     &'                                    ',

     &'                                    ',

     &'When you cite this program, currentl',

     &'y the official reference is         ',

     &'T. Sjostrand, Computer Physics Commu',

     &'n. 82 (1994) 74.                    ',

     &'The supersymmetry extensions are des',

     &'cribed in                           ',

     &'S. Mrenna, ANL-HEP-PR-96-63.        ',

     &'                                    ',

     &'Also remember that the program, to a',

     &' large extent, represents original  ',

     &'physics research. Other publications',

     &' of special relevance to your       '/

      DATA (refer(j),j=19,2*irefer)/

     &'studies may therefore deserve separa',

     &'te mention.                         ',

     &'                                    ',

     &'                                    ',

     &'Main author: Torbjorn Sjostrand; Dep',

     &'artment of Theoretical Physics 2,   ',

     &'  Lund University, Solvegatan 14A, S',

     &'-223 62 Lund, Sweden;               ',

     &'  phone: + 46 - 46 - 222 48 16; e-ma',

     &'il: torbjorn@thep.lu.se             ',

     &'SUSY author: Stephen Mrenna, Argonne',

     &' National Laboratory,               ',

     &'  9700 South Cass Avenue, Argonne, I',

     &'L 60439, USA;                       ',

     &'  phone: + 1 - 630 - 252 - 7615; e-m',

     &'ail: mrenna@hep.anl.gov             '/


C...Check that PYDATA linked.

      IF(mstp(183)/10.NE.199) THEN

        WRITE(mstu(11),'(1X,A)')

     &  'Error: PYDATA has not been linked.'

        WRITE(mstu(11),'(1X,A)') 'Execution stopped!'

        stop


C...Write current version number and current date+time.

      ELSE

        WRITE(vers,'(I1)') mstp(181)

        logo(28)(24:24)=vers

        WRITE(subv,'(I3)') mstp(182)

        logo(28)(26:28)=subv

        IF(mstp(182).LT.100) logo(28)(26:26)='0'

        WRITE(date,'(I2)') mstp(185)

        logo(29)(22:23)=date

        logo(29)(25:27)=month(mstp(184))

        WRITE(year,'(I4)') mstp(183)

        logo(29)(29:32)=year

        CALL pytime(idati)

        IF(idati(1).LE.0) THEN

          logo(31)='                                '

        ELSE

          WRITE(date,'(I2)') idati(3)

          logo(31)(8:9)=date

          logo(31)(11:13)=month(max(1,min(12,idati(2))))

          WRITE(year,'(I4)') idati(1)

          logo(31)(15:18)=year

          WRITE(hour,'(I2)') idati(4)

          logo(31)(23:24)=hour

          WRITE(minu,'(I2)') idati(5)

          logo(31)(26:27)=minu

          IF(idati(5).LT.10) logo(31)(26:26)='0'

          WRITE(seco,'(I2)') idati(6)

          logo(31)(29:30)=seco

          IF(idati(6).LT.10) logo(31)(29:29)='0'

        ENDIF

      ENDIF


C...Loop over lines in header. Define page feed and side borders.

      DO 100 ilin=1,29+irefer

        line=' '

        IF(ilin.EQ.1) THEN

          line(1:1)='1'

        ELSE

          line(2:3)='**'

          line(78:79)='**'

        ENDIF


C...Separator lines and logos.

        IF(ilin.EQ.2.OR.ilin.EQ.3.OR.ilin.GE.28+irefer) THEN

          line(4:77)='***********************************************'//

     &    '***************************'

        ELSEIF(ilin.GE.6.AND.ilin.LE.24) THEN

          line(6:37)=logo(ilin-5)

          line(44:75)=logo(ilin+14)

        ELSEIF(ilin.GE.26.AND.ilin.LE.25+irefer) THEN

          line(5:40)=refer(2*ilin-51)

          line(41:76)=refer(2*ilin-50)

        ENDIF


C...Write lines to appropriate unit.

        IF(mstu(183)/10.EQ.199) THEN

          WRITE(mstu(11),'(A79)') line

        ELSE

          WRITE(*,'(A79)') line

        ENDIF

  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYUPDA

C...Facilitates the updating of particle and decay data

C...by allowing it to be done in an external file.


      SUBROUTINE pyupda(MUPDA,LFN)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      common/pydat4/chaf(500,2)

      CHARACTER chaf*16

      common/pyint4/mwid(500),wids(500,5)

      SAVE /pydat1/,/pydat2/,/pydat3/,/pydat4/,/pyint4/

C...Local arrays, character variables and data.

      CHARACTER chinl*120,chkf*9,chvar(22)*9,chlin*72,

     &chblk(20)*72,chold*16,chtmp*16,chnew*16,chcom*24

      DATA chvar/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',

     &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',

     &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I)  ',

     &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',

     &'CHAF(I,1)','CHAF(I,2)','MWID(I)  '/


C...Write header if not yet done.

      IF(mstu(12).GE.1) CALL pylist(0)


C...Write information on file for editing.

      IF(mupda.EQ.1) THEN

        DO 110 kc=1,500

          WRITE(lfn,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),

     &    (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),

     &    mwid(kc),mdcy(kc,1)

          DO 100 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1

            WRITE(lfn,5100) mdme(idc,1),mdme(idc,2),brat(idc),

     &      (kfdp(idc,j),j=1,5)

  100     CONTINUE

  110   CONTINUE


C...Read complete set of information from edited file or

C...read partial set of new or updated information from edited file.

      ELSEIF(mupda.EQ.2.OR.mupda.EQ.3) THEN


C...Reset counters.

        kcc=100

        ndc=0

        chkf='         '

        IF(mupda.EQ.2) THEN

          DO 120 i=1,mstu(6)

            kchg(i,4)=0

  120     CONTINUE

        ELSE

          DO 130 kc=1,mstu(6)

            IF(kc.GT.100.AND.kchg(kc,4).GT.100) kcc=kc

            ndc=max(ndc,mdcy(kc,2)+mdcy(kc,3)-1)

  130     CONTINUE

        ENDIF


C...Begin of loop: read new line; unknown whether particle or

C...decay data.

  140   READ(lfn,5200,end=190) chinl


C...Identify particle code and whether already defined  (for MUPDA=3).

        IF(chinl(2:10).NE.'         ') THEN

          chkf=chinl(2:10)

          READ(chkf,5300) kf

          IF(mupda.EQ.2) THEN

            IF(kf.LE.100) THEN

              kc=kf

            ELSE

              kcc=kcc+1

              kc=kcc

            ENDIF

          ELSE

            kcrep=0

            IF(kf.LE.100) THEN

              kcrep=kf

            ELSE

              DO 150 kcr=101,kcc

                IF(kchg(kcr,4).EQ.kf) kcrep=kcr

  150         CONTINUE

            ENDIF

C...Remove duplicate old decay data.

            IF(kcrep.NE.0) THEN

              idcrep=mdcy(kcrep,2)

              ndcrep=mdcy(kcrep,3)

              DO 160 i=1,kcc

                IF(mdcy(i,2).GT.idcrep) mdcy(i,2)=mdcy(i,2)-ndcrep

  160         CONTINUE

              DO 180 i=idcrep,ndc-ndcrep

                mdme(i,1)=mdme(i+ndcrep,1)

                mdme(i,2)=mdme(i+ndcrep,2)

                brat(i)=brat(i+ndcrep)

                DO 170 j=1,5

                  kfdp(i,j)=kfdp(i+ndcrep,j)

  170           CONTINUE

  180         CONTINUE

              ndc=ndc-ndcrep

              kc=kcrep

            ELSE

              kcc=kcc+1

              kc=kcc

            ENDIF

          ENDIF


C...Study line with particle data.

          IF(kc.GT.mstu(6)) CALL pyerrm(27,

     &    '(PYUPDA:) Particle arrays full by KF ='//chkf)

          READ(chinl,5000) kchg(kc,4),(chaf(kc,j1),j1=1,2),

     &    (kchg(kc,j2),j2=1,3),(pmas(kc,j3),j3=1,4),

     &    mwid(kc),mdcy(kc,1)

          mdcy(kc,2)=0

          mdcy(kc,3)=0


C...Study line with decay data.

        ELSE

          ndc=ndc+1

          IF(ndc.GT.mstu(7)) CALL pyerrm(27,

     &    '(PYUPDA:) Decay data arrays full by KF ='//chkf)

          IF(mdcy(kc,2).EQ.0) mdcy(kc,2)=ndc

          mdcy(kc,3)=mdcy(kc,3)+1

          READ(chinl,5100) mdme(ndc,1),mdme(ndc,2),brat(ndc),

     &    (kfdp(ndc,j),j=1,5)

        ENDIF


C...End of loop; ensure that PYCOMP tables are updated.

        goto 140

  190   CONTINUE

        mstu(20)=0


C...Perform possible tests that new information is consistent.

        mstj24=mstj(24)

        mstj(24)=0

        DO 220 kc=1,mstu(6)

          kf=kchg(kc,4)

          IF(kf.EQ.0) goto 220

          WRITE(chkf,5300) kf

          IF(min(pmas(kc,1),pmas(kc,2),pmas(kc,3),pmas(kc,1)-pmas(kc,3),

     &    pmas(kc,4)).LT.0d0.OR.mdcy(kc,3).LT.0) CALL pyerrm(17,

     &    '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//chkf)

          brsum=0d0

          DO 210 idc=mdcy(kc,2),mdcy(kc,2)+mdcy(kc,3)-1

            IF(mdme(idc,2).GT.80) goto 210

            kq=kchg(kc,1)

            pms=pmas(kc,1)-pmas(kc,3)-parj(64)

            merr=0

            DO 200 j=1,5

              kp=kfdp(idc,j)

              IF(kp.EQ.0.OR.kp.EQ.81.OR.iabs(kp).EQ.82) THEN

                IF(kp.EQ.81) kq=0

              ELSEIF(pycomp(kp).EQ.0) THEN

                merr=3

              ELSE

                kq=kq-pychge(kp)

                pms=pms-pymass(kp)

                kpc=pycomp(kp)

                pms=pms-pmas(kpc,1)

                IF(mstj(24).GT.0) pms=pms+0.5d0*min(pmas(kpc,2),

     &          pmas(kpc,3))

              ENDIF

  200       CONTINUE

            IF(kq.NE.0) merr=max(2,merr)

            IF(mwid(kc).EQ.0.AND.kf.NE.311.AND.pms.LT.0d0)

     &      merr=max(1,merr)

            IF(merr.EQ.3) CALL pyerrm(17,

     &      '(PYUPDA:) Unknown particle code in decay of KF ='//chkf)

            IF(merr.EQ.2) CALL pyerrm(17,

     &      '(PYUPDA:) Charge not conserved in decay of KF ='//chkf)

            IF(merr.EQ.1) CALL pyerrm(7,

     &      '(PYUPDA:) Kinematically unallowed decay of KF ='//chkf)

            brsum=brsum+brat(idc)

  210     CONTINUE

          WRITE(chtmp,5500) brsum

          IF(abs(brsum).GT.0.0005d0.AND.abs(brsum-1d0).GT.0.0005d0)

     &    CALL pyerrm(7,'(PYUPDA:) Sum of branching ratios is '//

     &    chtmp(9:16)//' for KF ='//chkf)

  220   CONTINUE

        mstj(24)=mstj24


C...Write DATA statements for inclusion in program.

      ELSEIF(mupda.EQ.4) THEN


C...Find out how many codes and decay channels are actually used.

        kcc=0

        ndc=0

        DO 230 i=1,mstu(6)

          IF(kchg(i,4).NE.0) THEN

            kcc=i

            ndc=max(ndc,mdcy(i,2)+mdcy(i,3)-1)

          ENDIF

  230   CONTINUE


C...Initialize writing of DATA statements for inclusion in program.

        DO 300 ivar=1,22

          ndim=mstu(6)

          IF(ivar.GE.12.AND.ivar.LE.19) ndim=mstu(7)

          nlin=1

          chlin=' '

          chlin(7:35)='DATA ('//chvar(ivar)//',I=   1,    )/'

          llin=35

          chold='START'


C...Loop through variables for conversion to characters.

          DO 280 idim=1,ndim

            IF(ivar.EQ.1) WRITE(chtmp,5400) kchg(idim,1)

            IF(ivar.EQ.2) WRITE(chtmp,5400) kchg(idim,2)

            IF(ivar.EQ.3) WRITE(chtmp,5400) kchg(idim,3)

            IF(ivar.EQ.4) WRITE(chtmp,5400) kchg(idim,4)

            IF(ivar.EQ.5) WRITE(chtmp,5500) pmas(idim,1)

            IF(ivar.EQ.6) WRITE(chtmp,5500) pmas(idim,2)

            IF(ivar.EQ.7) WRITE(chtmp,5500) pmas(idim,3)

            IF(ivar.EQ.8) WRITE(chtmp,5500) pmas(idim,4)

            IF(ivar.EQ.9) WRITE(chtmp,5400) mdcy(idim,1)

            IF(ivar.EQ.10) WRITE(chtmp,5400) mdcy(idim,2)

            IF(ivar.EQ.11) WRITE(chtmp,5400) mdcy(idim,3)

            IF(ivar.EQ.12) WRITE(chtmp,5400) mdme(idim,1)

            IF(ivar.EQ.13) WRITE(chtmp,5400) mdme(idim,2)

            IF(ivar.EQ.14) WRITE(chtmp,5600) brat(idim)

            IF(ivar.EQ.15) WRITE(chtmp,5400) kfdp(idim,1)

            IF(ivar.EQ.16) WRITE(chtmp,5400) kfdp(idim,2)

            IF(ivar.EQ.17) WRITE(chtmp,5400) kfdp(idim,3)

            IF(ivar.EQ.18) WRITE(chtmp,5400) kfdp(idim,4)

            IF(ivar.EQ.19) WRITE(chtmp,5400) kfdp(idim,5)

            IF(ivar.EQ.20) chtmp=chaf(idim,1)

            IF(ivar.EQ.21) chtmp=chaf(idim,2)

            IF(ivar.EQ.22) WRITE(chtmp,5400) mwid(idim)


C...Replace variables beyond what is properly defined.

            IF(ivar.LE.4) THEN

              IF(idim.GT.kcc) chtmp='               0'

            ELSEIF(ivar.LE.8) THEN

              IF(idim.GT.kcc) chtmp='             0.0'

            ELSEIF(ivar.LE.11) THEN

              IF(idim.GT.kcc) chtmp='               0'

            ELSEIF(ivar.LE.13) THEN

              IF(idim.GT.ndc) chtmp='               0'

            ELSEIF(ivar.LE.14) THEN

              IF(idim.GT.ndc) chtmp='             0.0'

            ELSEIF(ivar.LE.19) THEN

              IF(idim.GT.ndc) chtmp='               0'

            ELSEIF(ivar.LE.21) THEN

              IF(idim.GT.kcc) chtmp='                '

            ELSE

              IF(idim.GT.kcc) chtmp='               0'

            ENDIF


C...Length of variable, trailing decimal zeros, quotation marks.

            llow=1

            lhig=1

            DO 240 ll=1,16

              IF(chtmp(17-ll:17-ll).NE.' ') llow=17-ll

              IF(chtmp(ll:ll).NE.' ') lhig=ll

  240       CONTINUE

            chnew=chtmp(llow:lhig)//' '

            lnew=1+lhig-llow

            IF((ivar.GE.5.AND.ivar.LE.8).OR.ivar.EQ.14) THEN

              lnew=lnew+1

  250         lnew=lnew-1

              IF(lnew.GE.2.AND.chnew(lnew:lnew).EQ.'0') goto 250

              IF(chnew(lnew:lnew).EQ.'.') lnew=lnew-1

              IF(lnew.EQ.0) THEN

                chnew(1:3)='0D0'

                lnew=3

              ELSE

                chnew(lnew+1:lnew+2)='D0'

                lnew=lnew+2

              ENDIF

            ELSEIF(ivar.EQ.20.OR.ivar.EQ.21) THEN

              DO 260 ll=lnew,1,-1

                IF(chnew(ll:ll).EQ.'''') THEN

                  chtmp=chnew

                  chnew=chtmp(1:ll)//''''//chtmp(ll+1:11)

                  lnew=lnew+1

                ENDIF

  260         CONTINUE

              lnew=min(14,lnew)

              chtmp=chnew

              chnew(1:lnew+2)=''''//chtmp(1:lnew)//''''

              lnew=lnew+2

            ENDIF


C...Form composite character string, often including repetition counter.

            IF(chnew.NE.chold) THEN

              nrpt=1

              chold=chnew

              chcom=chnew

              lcom=lnew

            ELSE

              lrpt=lnew+1

              IF(nrpt.GE.2) lrpt=lnew+3

              IF(nrpt.GE.10) lrpt=lnew+4

              IF(nrpt.GE.100) lrpt=lnew+5

              IF(nrpt.GE.1000) lrpt=lnew+6

              llin=llin-lrpt

              nrpt=nrpt+1

              WRITE(chtmp,5400) nrpt

              lrpt=1

              IF(nrpt.GE.10) lrpt=2

              IF(nrpt.GE.100) lrpt=3

              IF(nrpt.GE.1000) lrpt=4

              chcom(1:lrpt+1+lnew)=chtmp(17-lrpt:16)//'*'//chnew(1:lnew)

              lcom=lrpt+1+lnew

            ENDIF


C...Add characters to end of line, to new line (after storing old line),

C...or to new block of lines (after writing old block).

            IF(llin+lcom.LE.70) THEN

              chlin(llin+1:llin+lcom+1)=chcom(1:lcom)//','

              llin=llin+lcom+1

            ELSEIF(nlin.LE.19) THEN

              chlin(llin+1:72)=' '

              chblk(nlin)=chlin

              nlin=nlin+1

              chlin(6:6+lcom+1)='&'//chcom(1:lcom)//','

              llin=6+lcom+1

            ELSE

              chlin(llin:72)='/'//' '

              chblk(nlin)=chlin

              WRITE(chtmp,5400) idim-nrpt

              chblk(1)(30:33)=chtmp(13:16)

              DO 270 ilin=1,nlin

                WRITE(lfn,5700) chblk(ilin)

  270         CONTINUE

              nlin=1

              chlin=' '

              chlin(7:35+lcom+1)='DATA ('//chvar(ivar)//

     &        ',I=    ,    )/'//chcom(1:lcom)//','

              WRITE(chtmp,5400) idim-nrpt+1

              chlin(25:28)=chtmp(13:16)

              llin=35+lcom+1

            ENDIF

  280     CONTINUE


C...Write final block of lines.

          chlin(llin:72)='/'//' '

          chblk(nlin)=chlin

          WRITE(chtmp,5400) ndim

          chblk(1)(30:33)=chtmp(13:16)

          DO 290 ilin=1,nlin

            WRITE(lfn,5700) chblk(ilin)

  290     CONTINUE

  300   CONTINUE

      ENDIF


C...Formats for reading and writing particle data.

 5000 FORMAT(1x,i9,2x,a16,2x,a16,3i3,3f12.5,1p,e13.5,2i3)

 5100 FORMAT(10x,2i5,f12.6,5i10)

 5200 FORMAT(a120)

 5300 FORMAT(i9)

 5400 FORMAT(i16)

 5500 FORMAT(f16.5)

 5600 FORMAT(f16.6)

 5700 FORMAT(a72)


      RETURN

      END


C*********************************************************************


C...PYK

C...Provides various integer-valued event related data.


      FUNCTION pyk(I,J)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Default value. For I=0 number of entries, number of stable entries

C...or 3 times total charge.

      pyk=0

      IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN

      ELSEIF(i.EQ.0.AND.j.EQ.1) THEN

        pyk=n

      ELSEIF(i.EQ.0.AND.(j.EQ.2.OR.j.EQ.6)) THEN

        DO 100 i1=1,n

          IF(j.EQ.2.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+1

          IF(j.EQ.6.AND.k(i1,1).GE.1.AND.k(i1,1).LE.10) pyk=pyk+

     &    pychge(k(i1,2))

  100   CONTINUE

      ELSEIF(i.EQ.0) THEN


C...For I > 0 direct readout of K matrix or charge.

      ELSEIF(j.LE.5) THEN

        pyk=k(i,j)

      ELSEIF(j.EQ.6) THEN

        pyk=pychge(k(i,2))


C...Status (existing/fragmented/decayed), parton/hadron separation.

      ELSEIF(j.LE.8) THEN

        IF(k(i,1).GE.1.AND.k(i,1).LE.10) pyk=1

        IF(j.EQ.8) pyk=pyk*k(i,2)

      ELSEIF(j.LE.12) THEN

        kfa=iabs(k(i,2))

        kc=pycomp(kfa)

        kq=0

        IF(kc.NE.0) kq=kchg(kc,2)

        IF(j.EQ.9.AND.kc.NE.0.AND.kq.NE.0) pyk=k(i,2)

        IF(j.EQ.10.AND.kc.NE.0.AND.kq.EQ.0) pyk=k(i,2)

        IF(j.EQ.11) pyk=kc

        IF(j.EQ.12) pyk=kq*isign(1,k(i,2))


C...Heaviest flavour in hadron/diquark.

      ELSEIF(j.EQ.13) THEN

        kfa=iabs(k(i,2))

        pyk=mod(kfa/100,10)*(-1)**mod(kfa/100,10)

        IF(kfa.LT.10) pyk=kfa

        IF(mod(kfa/1000,10).NE.0) pyk=mod(kfa/1000,10)

        pyk=pyk*isign(1,k(i,2))


C...Particle history: generation, ancestor, rank.

      ELSEIF(j.LE.15) THEN

        i2=i

        i1=i

  110   pyk=pyk+1

        i2=i1

        i1=k(i1,3)

        IF(i1.GT.0.AND.k(i1,1).GT.0.AND.k(i1,1).LE.20) goto 110

        IF(j.EQ.15) pyk=i2

      ELSEIF(j.EQ.16) THEN

        kfa=iabs(k(i,2))

        IF(k(i,1).LE.20.AND.((kfa.GE.11.AND.kfa.LE.20).OR.kfa.EQ.22.OR.

     &  (kfa.GT.100.AND.mod(kfa/10,10).NE.0))) THEN

          i1=i

  120     i2=i1

          i1=k(i1,3)

          IF(i1.GT.0) THEN

            kfam=iabs(k(i1,2))

            ilp=1

            IF(kfam.NE.0.AND.kfam.LE.10) ilp=0

            IF(kfam.EQ.21.OR.kfam.EQ.91.OR.kfam.EQ.92.OR.kfam.EQ.93)

     &      ilp=0

            IF(kfam.GT.100.AND.mod(kfam/10,10).EQ.0) ilp=0

            IF(ilp.EQ.1) goto 120

          ENDIF

          IF(k(i1,1).EQ.12) THEN

            DO 130 i3=i1+1,i2

              IF(k(i3,3).EQ.k(i2,3).AND.k(i3,2).NE.91.AND.k(i3,2).NE.92

     &        .AND.k(i3,2).NE.93) pyk=pyk+1

  130       CONTINUE

          ELSE

            i3=i2

  140       pyk=pyk+1

            i3=i3+1

            IF(i3.LT.n.AND.k(i3,3).EQ.k(i2,3)) goto 140

          ENDIF

        ENDIF


C...Particle coming from collapsing jet system or not.

      ELSEIF(j.EQ.17) THEN

        i1=i

  150   pyk=pyk+1

        i3=i1

        i1=k(i1,3)

        i0=max(1,i1)

        kc=pycomp(k(i0,2))

        IF(i1.EQ.0.OR.k(i0,1).LE.0.OR.k(i0,1).GT.20.OR.kc.EQ.0) THEN

          IF(pyk.EQ.1) pyk=-1

          IF(pyk.GT.1) pyk=0

          RETURN

        ENDIF

        IF(kchg(kc,2).EQ.0) goto 150

        IF(k(i1,1).NE.12) pyk=0

        IF(k(i1,1).NE.12) RETURN

        i2=i1

  160   i2=i2+1

        IF(i2.LT.n.AND.k(i2,1).NE.11) goto 160

        k3m=k(i3-1,3)

        IF(k3m.GE.i1.AND.k3m.LE.i2) pyk=0

        k3p=k(i3+1,3)

        IF(i3.LT.n.AND.k3p.GE.i1.AND.k3p.LE.i2) pyk=0


C...Number of decay products. Colour flow.

      ELSEIF(j.EQ.18) THEN

        IF(k(i,1).EQ.11.OR.k(i,1).EQ.12) pyk=max(0,k(i,5)-k(i,4)+1)

        IF(k(i,4).EQ.0.OR.k(i,5).EQ.0) pyk=0

      ELSEIF(j.LE.22) THEN

        IF(k(i,1).NE.3.AND.k(i,1).NE.13.AND.k(i,1).NE.14) RETURN

        IF(j.EQ.19) pyk=mod(k(i,4)/mstu(5),mstu(5))

        IF(j.EQ.20) pyk=mod(k(i,5)/mstu(5),mstu(5))

        IF(j.EQ.21) pyk=mod(k(i,4),mstu(5))

        IF(j.EQ.22) pyk=mod(k(i,5),mstu(5))

      ELSE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYP

C...Provides various real-valued event related data.


      FUNCTION pyp(I,J)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local array.

      dimension psum(4)


C...Set default value. For I = 0 sum of momenta or charges,

C...or invariant mass of system.

      pyp=0d0

      IF(i.LT.0.OR.i.GT.mstu(4).OR.j.LE.0) THEN

      ELSEIF(i.EQ.0.AND.j.LE.4) THEN

        DO 100 i1=1,n

          IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+p(i1,j)

  100   CONTINUE

      ELSEIF(i.EQ.0.AND.j.EQ.5) THEN

        DO 120 j1=1,4

          psum(j1)=0d0

          DO 110 i1=1,n

            IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) psum(j1)=psum(j1)+

     &      p(i1,j1)

  110     CONTINUE

  120   CONTINUE

        pyp=sqrt(max(0d0,psum(4)**2-psum(1)**2-psum(2)**2-psum(3)**2))

      ELSEIF(i.EQ.0.AND.j.EQ.6) THEN

        DO 130 i1=1,n

          IF(k(i1,1).GT.0.AND.k(i1,1).LE.10) pyp=pyp+pychge(k(i1,2))/3d0

  130   CONTINUE

      ELSEIF(i.EQ.0) THEN


C...Direct readout of P matrix.

      ELSEIF(j.LE.5) THEN

        pyp=p(i,j)


C...Charge, total momentum, transverse momentum, transverse mass.

      ELSEIF(j.LE.12) THEN

        IF(j.EQ.6) pyp=pychge(k(i,2))/3d0

        IF(j.EQ.7.OR.j.EQ.8) pyp=p(i,1)**2+p(i,2)**2+p(i,3)**2

        IF(j.EQ.9.OR.j.EQ.10) pyp=p(i,1)**2+p(i,2)**2

        IF(j.EQ.11.OR.j.EQ.12) pyp=p(i,5)**2+p(i,1)**2+p(i,2)**2

        IF(j.EQ.8.OR.j.EQ.10.OR.j.EQ.12) pyp=sqrt(pyp)


C...Theta and phi angle in radians or degrees.

      ELSEIF(j.LE.16) THEN

        IF(j.LE.14) pyp=pyangl(p(i,3),sqrt(p(i,1)**2+p(i,2)**2))

        IF(j.GE.15) pyp=pyangl(p(i,1),p(i,2))

        IF(j.EQ.14.OR.j.EQ.16) pyp=pyp*180d0/paru(1)


C...True rapidity, rapidity with pion mass, pseudorapidity.

      ELSEIF(j.LE.19) THEN

        pmr=0d0

        IF(j.EQ.17) pmr=p(i,5)

        IF(j.EQ.18) pmr=pymass(211)

        pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)

        pyp=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),

     &  1d20)),p(i,3))


C...Energy and momentum fractions (only to be used in CM frame).

      ELSEIF(j.LE.25) THEN

        IF(j.EQ.20) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)/paru(21)

        IF(j.EQ.21) pyp=2d0*p(i,3)/paru(21)

        IF(j.EQ.22) pyp=2d0*sqrt(p(i,1)**2+p(i,2)**2)/paru(21)

        IF(j.EQ.23) pyp=2d0*p(i,4)/paru(21)

        IF(j.EQ.24) pyp=(p(i,4)+p(i,3))/paru(21)

        IF(j.EQ.25) pyp=(p(i,4)-p(i,3))/paru(21)

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYSPHE

C...Performs sphericity tensor analysis to give sphericity,

C...aplanarity and the related event axes.


      SUBROUTINE pysphe(SPH,APL)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension sm(3,3),sv(3,3)


C...Calculate matrix to be diagonalized.

      np=0

      DO 110 j1=1,3

        DO 100 j2=j1,3

          sm(j1,j2)=0d0

  100   CONTINUE

  110 CONTINUE

      ps=0d0

      DO 140 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 140

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 140

        ENDIF

        np=np+1

        pa=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

        pwt=1d0

        IF(abs(paru(41)-2d0).GT.0.001d0) pwt=

     &  max(1d-10,pa)**(paru(41)-2d0)

        DO 130 j1=1,3

          DO 120 j2=j1,3

            sm(j1,j2)=sm(j1,j2)+pwt*p(i,j1)*p(i,j2)

  120     CONTINUE

  130   CONTINUE

        ps=ps+pwt*pa**2

  140 CONTINUE


C...Very low multiplicities (0 or 1) not considered.

      IF(np.LE.1) THEN

        CALL pyerrm(8,'(PYSPHE:) too few particles for analysis')

        sph=-1d0

        apl=-1d0

        RETURN

      ENDIF

      DO 160 j1=1,3

        DO 150 j2=j1,3

          sm(j1,j2)=sm(j1,j2)/ps

  150   CONTINUE

  160 CONTINUE


C...Find eigenvalues to matrix (third degree equation).

      sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-

     &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0

      sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+

     &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+

     &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0

      sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)

      p(n+1,4)=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)

      p(n+3,4)=1d0/3d0+sqrt(-sq)*min(2d0*sp,-sqrt(3d0*(1d0-sp**2))-sp)

      p(n+2,4)=1d0-p(n+1,4)-p(n+3,4)

      IF(p(n+2,4).LT.1d-5) THEN

        CALL pyerrm(8,'(PYSPHE:) all particles back-to-back')

        sph=-1d0

        apl=-1d0

        RETURN

      ENDIF


C...Find first and last eigenvector by solving equation system.

      DO 240 i=1,3,2

        DO 180 j1=1,3

          sv(j1,j1)=sm(j1,j1)-p(n+i,4)

          DO 170 j2=j1+1,3

            sv(j1,j2)=sm(j1,j2)

            sv(j2,j1)=sm(j1,j2)

  170     CONTINUE

  180   CONTINUE

        smax=0d0

        DO 200 j1=1,3

          DO 190 j2=1,3

            IF(abs(sv(j1,j2)).LE.smax) goto 190

            ja=j1

            jb=j2

            smax=abs(sv(j1,j2))

  190     CONTINUE

  200   CONTINUE

        smax=0d0

        DO 220 j3=ja+1,ja+2

          j1=j3-3*((j3-1)/3)

          rl=sv(j1,jb)/sv(ja,jb)

          DO 210 j2=1,3

            sv(j1,j2)=sv(j1,j2)-rl*sv(ja,j2)

            IF(abs(sv(j1,j2)).LE.smax) goto 210

            jc=j1

            smax=abs(sv(j1,j2))

  210     CONTINUE

  220   CONTINUE

        jb1=jb+1-3*(jb/3)

        jb2=jb+2-3*((jb+1)/3)

        p(n+i,jb1)=-sv(jc,jb2)

        p(n+i,jb2)=sv(jc,jb1)

        p(n+i,jb)=-(sv(ja,jb1)*p(n+i,jb1)+sv(ja,jb2)*p(n+i,jb2))/

     &  sv(ja,jb)

        pa=sqrt(p(n+i,1)**2+p(n+i,2)**2+p(n+i,3)**2)

        sgn=(-1d0)**int(pyr(0)+0.5d0)

        DO 230 j=1,3

          p(n+i,j)=sgn*p(n+i,j)/pa

  230   CONTINUE

  240 CONTINUE


C...Middle axis orthogonal to other two. Fill other codes.

      sgn=(-1d0)**int(pyr(0)+0.5d0)

      p(n+2,1)=sgn*(p(n+1,2)*p(n+3,3)-p(n+1,3)*p(n+3,2))

      p(n+2,2)=sgn*(p(n+1,3)*p(n+3,1)-p(n+1,1)*p(n+3,3))

      p(n+2,3)=sgn*(p(n+1,1)*p(n+3,2)-p(n+1,2)*p(n+3,1))

      DO 260 i=1,3

        k(n+i,1)=31

        k(n+i,2)=95

        k(n+i,3)=i

        k(n+i,4)=0

        k(n+i,5)=0

        p(n+i,5)=0d0

        DO 250 j=1,5

          v(i,j)=0d0

  250   CONTINUE

  260 CONTINUE


C...Calculate sphericity and aplanarity. Select storing option.

      sph=1.5d0*(p(n+2,4)+p(n+3,4))

      apl=1.5d0*p(n+3,4)

      mstu(61)=n+1

      mstu(62)=np

      IF(mstu(43).LE.1) mstu(3)=3

      IF(mstu(43).GE.2) n=n+3


      RETURN

      END


C*********************************************************************


C...PYTHRU

C...Performs thrust analysis to give thrust, oblateness

C...and the related event axes.


      SUBROUTINE pythru(THR,OBL)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension tdi(3),tpr(3)


C...Take copy of particles that are to be considered in thrust analysis.

      np=0

      ps=0d0

      DO 100 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 100

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 100

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 100

        ENDIF

        IF(n+np+mstu(44)+15.GE.mstu(4)-mstu(32)-5) THEN

          CALL pyerrm(11,'(PYTHRU:) no more memory left in PYJETS')

          thr=-2d0

          obl=-2d0

          RETURN

        ENDIF

        np=np+1

        k(n+np,1)=23

        p(n+np,1)=p(i,1)

        p(n+np,2)=p(i,2)

        p(n+np,3)=p(i,3)

        p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

        p(n+np,5)=1d0

        IF(abs(paru(42)-1d0).GT.0.001d0) p(n+np,5)=

     &  p(n+np,4)**(paru(42)-1d0)

        ps=ps+p(n+np,4)*p(n+np,5)

  100 CONTINUE


C...Very low multiplicities (0 or 1) not considered.

      IF(np.LE.1) THEN

        CALL pyerrm(8,'(PYTHRU:) too few particles for analysis')

        thr=-1d0

        obl=-1d0

        RETURN

      ENDIF


C...Loop over thrust and major. T axis along z direction in latter case.

      DO 320 ild=1,2

        IF(ild.EQ.2) THEN

          k(n+np+1,1)=31

          phi=pyangl(p(n+np+1,1),p(n+np+1,2))

          mstu(33)=1

          CALL pyrobo(n+1,n+np+1,0d0,-phi,0d0,0d0,0d0)

          the=pyangl(p(n+np+1,3),p(n+np+1,1))

          CALL pyrobo(n+1,n+np+1,-the,0d0,0d0,0d0,0d0)

        ENDIF


C...Find and order particles with highest p (pT for major).

        DO 110 ilf=n+np+4,n+np+mstu(44)+4

          p(ilf,4)=0d0

  110   CONTINUE

        DO 160 i=n+1,n+np

          IF(ild.EQ.2) p(i,4)=sqrt(p(i,1)**2+p(i,2)**2)

          DO 130 ilf=n+np+mstu(44)+3,n+np+4,-1

            IF(p(i,4).LE.p(ilf,4)) goto 140

            DO 120 j=1,5

              p(ilf+1,j)=p(ilf,j)

  120       CONTINUE

  130     CONTINUE

          ilf=n+np+3

  140     DO 150 j=1,5

            p(ilf+1,j)=p(i,j)

  150     CONTINUE

  160   CONTINUE


C...Find and order initial axes with highest thrust (major).

        DO 170 ilg=n+np+mstu(44)+5,n+np+mstu(44)+15

          p(ilg,4)=0d0

  170   CONTINUE

        nc=2**(min(mstu(44),np)-1)

        DO 250 ilc=1,nc

          DO 180 j=1,3

            tdi(j)=0d0

  180     CONTINUE

          DO 200 ilf=1,min(mstu(44),np)

            sgn=p(n+np+ilf+3,5)

            IF(2**ilf*((ilc+2**(ilf-1)-1)/2**ilf).GE.ilc) sgn=-sgn

            DO 190 j=1,4-ild

              tdi(j)=tdi(j)+sgn*p(n+np+ilf+3,j)

  190       CONTINUE

  200     CONTINUE

          tds=tdi(1)**2+tdi(2)**2+tdi(3)**2

          DO 220 ilg=n+np+mstu(44)+min(ilc,10)+4,n+np+mstu(44)+5,-1

            IF(tds.LE.p(ilg,4)) goto 230

            DO 210 j=1,4

              p(ilg+1,j)=p(ilg,j)

  210       CONTINUE

  220     CONTINUE

          ilg=n+np+mstu(44)+4

  230     DO 240 j=1,3

            p(ilg+1,j)=tdi(j)

  240     CONTINUE

          p(ilg+1,4)=tds

  250   CONTINUE


C...Iterate direction of axis until stable maximum.

        p(n+np+ild,4)=0d0

        ilg=0

  260   ilg=ilg+1

        thp=0d0

  270   thps=thp

        DO 280 j=1,3

          IF(thp.LE.1d-10) tdi(j)=p(n+np+mstu(44)+4+ilg,j)

          IF(thp.GT.1d-10) tdi(j)=tpr(j)

          tpr(j)=0d0

  280   CONTINUE

        DO 300 i=n+1,n+np

          sgn=sign(p(i,5),tdi(1)*p(i,1)+tdi(2)*p(i,2)+tdi(3)*p(i,3))

          DO 290 j=1,4-ild

            tpr(j)=tpr(j)+sgn*p(i,j)

  290     CONTINUE

  300   CONTINUE

        thp=sqrt(tpr(1)**2+tpr(2)**2+tpr(3)**2)/ps

        IF(thp.GE.thps+paru(48)) goto 270


C...Save good axis. Try new initial axis until a number of tries agree.

        IF(thp.LT.p(n+np+ild,4)-paru(48).AND.ilg.LT.min(10,nc)) goto 260

        IF(thp.GT.p(n+np+ild,4)+paru(48)) THEN

          iagr=0

          sgn=(-1d0)**int(pyr(0)+0.5d0)

          DO 310 j=1,3

            p(n+np+ild,j)=sgn*tpr(j)/(ps*thp)

  310     CONTINUE

          p(n+np+ild,4)=thp

          p(n+np+ild,5)=0d0

        ENDIF

        iagr=iagr+1

        IF(iagr.LT.mstu(45).AND.ilg.LT.min(10,nc)) goto 260

  320 CONTINUE


C...Find minor axis and value by orthogonality.

      sgn=(-1d0)**int(pyr(0)+0.5d0)

      p(n+np+3,1)=-sgn*p(n+np+2,2)

      p(n+np+3,2)=sgn*p(n+np+2,1)

      p(n+np+3,3)=0d0

      thp=0d0

      DO 330 i=n+1,n+np

        thp=thp+p(i,5)*abs(p(n+np+3,1)*p(i,1)+p(n+np+3,2)*p(i,2))

  330 CONTINUE

      p(n+np+3,4)=thp/ps

      p(n+np+3,5)=0d0


C...Fill axis information. Rotate back to original coordinate system.

      DO 350 ild=1,3

        k(n+ild,1)=31

        k(n+ild,2)=96

        k(n+ild,3)=ild

        k(n+ild,4)=0

        k(n+ild,5)=0

        DO 340 j=1,5

          p(n+ild,j)=p(n+np+ild,j)

          v(n+ild,j)=0d0

  340   CONTINUE

  350 CONTINUE

      CALL pyrobo(n+1,n+3,the,phi,0d0,0d0,0d0)


C...Calculate thrust and oblateness. Select storing option.

      thr=p(n+1,4)

      obl=p(n+2,4)-p(n+3,4)

      mstu(61)=n+1

      mstu(62)=np

      IF(mstu(43).LE.1) mstu(3)=3

      IF(mstu(43).GE.2) n=n+3


      RETURN

      END


C*********************************************************************


C...PYCLUS

C...Subdivides the particle content of an event into jets/clusters.


      SUBROUTINE pyclus(NJET)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays and saved variables.

      dimension ps(5)

      SAVE nsav,np,ps,pss,rinit,npre,nrem


C...Functions: distance measure in pT, (pseudo)mass or Durham pT.

      r2t(i1,i2)=(p(i1,5)*p(i2,5)-p(i1,1)*p(i2,1)-p(i1,2)*p(i2,2)-

     &p(i1,3)*p(i2,3))*2d0*p(i1,5)*p(i2,5)/(0.0001d0+p(i1,5)+p(i2,5))**2

      r2m(i1,i2)=2d0*p(i1,4)*p(i2,4)*(1d0-(p(i1,1)*p(i2,1)+p(i1,2)*

     &p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))

      r2d(i1,i2)=2d0*min(p(i1,4),p(i2,4))**2*(1d0-(p(i1,1)*p(i2,1)+

     &p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/(p(i1,5)*p(i2,5)))


C...If first time, reset. If reentering, skip preliminaries.

      IF(mstu(48).LE.0) THEN

        np=0

        DO 100 j=1,5

          ps(j)=0d0

  100   CONTINUE

        pss=0d0

        pimass=pmas(pycomp(211),1)

      ELSE

        njet=nsav

        IF(mstu(43).GE.2) n=n-njet

        DO 110 i=n+1,n+njet

          p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

  110   CONTINUE

        IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN

          r2acc=paru(44)**2

        ELSE

          r2acc=paru(45)*ps(5)**2

        ENDIF

        nloop=0

        goto 300

      ENDIF


C...Find which particles are to be considered in cluster search.

      DO 140 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 140

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 140

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 140

        ENDIF

        IF(n+2*np.GE.mstu(4)-mstu(32)-5) THEN

          CALL pyerrm(11,'(PYCLUS:) no more memory left in PYJETS')

          njet=-1

          RETURN

        ENDIF


C...Take copy of these particles, with space left for jets later on.

        np=np+1

        k(n+np,3)=i

        DO 120 j=1,5

          p(n+np,j)=p(i,j)

  120   CONTINUE

        IF(mstu(42).EQ.0) p(n+np,5)=0d0

        IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass

        p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

        p(n+np,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

        DO 130 j=1,4

          ps(j)=ps(j)+p(n+np,j)

  130   CONTINUE

        pss=pss+p(n+np,5)

  140 CONTINUE

      DO 160 i=n+1,n+np

        k(i+np,3)=k(i,3)

        DO 150 j=1,5

          p(i+np,j)=p(i,j)

  150   CONTINUE

  160 CONTINUE

      ps(5)=sqrt(max(0d0,ps(4)**2-ps(1)**2-ps(2)**2-ps(3)**2))


C...Very low multiplicities not considered.

      IF(np.LT.mstu(47)) THEN

        CALL pyerrm(8,'(PYCLUS:) too few particles for analysis')

        njet=-1

        RETURN

      ENDIF


C...Find precluster configuration. If too few jets, make harder cuts.

      nloop=0

      IF(mstu(46).LE.3.OR.mstu(46).EQ.5) THEN

        r2acc=paru(44)**2

      ELSE

        r2acc=paru(45)*ps(5)**2

      ENDIF

      rinit=1.25d0*paru(43)

      IF(np.LE.mstu(47)+2) rinit=0d0

  170 rinit=0.8d0*rinit

      npre=0

      nrem=np

      DO 180 i=n+np+1,n+2*np

        k(i,4)=0

  180 CONTINUE


C...Sum up small momentum region. Jet if enough absolute momentum.

      IF(mstu(46).LE.2) THEN

        DO 190 j=1,4

          p(n+1,j)=0d0

  190   CONTINUE

        DO 210 i=n+np+1,n+2*np

          IF(p(i,5).GT.2d0*rinit) goto 210

          nrem=nrem-1

          k(i,4)=1

          DO 200 j=1,4

            p(n+1,j)=p(n+1,j)+p(i,j)

  200     CONTINUE

  210   CONTINUE

        p(n+1,5)=sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2)

        IF(p(n+1,5).GT.2d0*rinit) npre=1

        IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170

        IF(nrem.EQ.0) goto 170

      ENDIF


C...Find fastest remaining particle.

  220 npre=npre+1

      pmax=0d0

      DO 230 i=n+np+1,n+2*np

        IF(k(i,4).NE.0.OR.p(i,5).LE.pmax) goto 230

        imax=i

        pmax=p(i,5)

  230 CONTINUE

      DO 240 j=1,5

        p(n+npre,j)=p(imax,j)

  240 CONTINUE

      nrem=nrem-1

      k(imax,4)=npre


C...Sum up precluster around it according to pT separation.

      IF(mstu(46).LE.2) THEN

        DO 260 i=n+np+1,n+2*np

          IF(k(i,4).NE.0) goto 260

          r2=r2t(i,imax)

          IF(r2.GT.rinit**2) goto 260

          nrem=nrem-1

          k(i,4)=npre

          DO 250 j=1,4

            p(n+npre,j)=p(n+npre,j)+p(i,j)

  250     CONTINUE

  260   CONTINUE

        p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)


C...Sum up precluster around it according to mass or

C...Durham pT separation.

      ELSE

  270   imin=0

        r2min=rinit**2

        DO 280 i=n+np+1,n+2*np

          IF(k(i,4).NE.0) goto 280

          IF(mstu(46).LE.4) THEN

            r2=r2m(i,n+npre)

          ELSE

            r2=r2d(i,n+npre)

          ENDIF

          IF(r2.GE.r2min) goto 280

          imin=i

          r2min=r2

  280   CONTINUE

        IF(imin.NE.0) THEN

          DO 290 j=1,4

            p(n+npre,j)=p(n+npre,j)+p(imin,j)

  290     CONTINUE

          p(n+npre,5)=sqrt(p(n+npre,1)**2+p(n+npre,2)**2+p(n+npre,3)**2)

          nrem=nrem-1

          k(imin,4)=npre

          goto 270

        ENDIF

      ENDIF


C...Check if more preclusters to be found. Start over if too few.

      IF(rinit.GE.0.2d0*paru(43).AND.npre+nrem.LT.mstu(47)) goto 170

      IF(nrem.GT.0) goto 220

      njet=npre


C...Reassign all particles to nearest jet. Sum up new jet momenta.

  300 tsav=0d0

      psjt=0d0

  310 IF(mstu(46).LE.1) THEN

        DO 330 i=n+1,n+njet

          DO 320 j=1,4

            v(i,j)=0d0

  320     CONTINUE

  330   CONTINUE

        DO 360 i=n+np+1,n+2*np

          r2min=pss**2

          DO 340 ijet=n+1,n+njet

            IF(p(ijet,5).LT.rinit) goto 340

            r2=r2t(i,ijet)

            IF(r2.GE.r2min) goto 340

            imin=ijet

            r2min=r2

  340     CONTINUE

          k(i,4)=imin-n

          DO 350 j=1,4

            v(imin,j)=v(imin,j)+p(i,j)

  350     CONTINUE

  360   CONTINUE

        psjt=0d0

        DO 380 i=n+1,n+njet

          DO 370 j=1,4

            p(i,j)=v(i,j)

  370     CONTINUE

          p(i,5)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

          psjt=psjt+p(i,5)

  380   CONTINUE

      ENDIF


C...Find two closest jets.

      r2min=2d0*max(r2acc,ps(5)**2)

      DO 400 itry1=n+1,n+njet-1

        DO 390 itry2=itry1+1,n+njet

          IF(mstu(46).LE.2) THEN

            r2=r2t(itry1,itry2)

          ELSEIF(mstu(46).LE.4) THEN

            r2=r2m(itry1,itry2)

          ELSE

            r2=r2d(itry1,itry2)

          ENDIF

          IF(r2.GE.r2min) goto 390

          imin1=itry1

          imin2=itry2

          r2min=r2

  390   CONTINUE

  400 CONTINUE


C...If allowed, join two closest jets and start over.

      IF(njet.GT.mstu(47).AND.r2min.LT.r2acc) THEN

        irec=min(imin1,imin2)

        idel=max(imin1,imin2)

        DO 410 j=1,4

          p(irec,j)=p(imin1,j)+p(imin2,j)

  410   CONTINUE

        p(irec,5)=sqrt(p(irec,1)**2+p(irec,2)**2+p(irec,3)**2)

        DO 430 i=idel+1,n+njet

          DO 420 j=1,5

            p(i-1,j)=p(i,j)

  420     CONTINUE

  430   CONTINUE

        IF(mstu(46).GE.2) THEN

          DO 440 i=n+np+1,n+2*np

            iori=n+k(i,4)

            IF(iori.EQ.idel) k(i,4)=irec-n

            IF(iori.GT.idel) k(i,4)=k(i,4)-1

  440     CONTINUE

        ENDIF

        njet=njet-1

        goto 300


C...Divide up broad jet if empty cluster in list of final ones.

      ELSEIF(njet.EQ.mstu(47).AND.mstu(46).LE.1.AND.nloop.LE.2) THEN

        DO 450 i=n+1,n+njet

          k(i,5)=0

  450   CONTINUE

        DO 460 i=n+np+1,n+2*np

          k(n+k(i,4),5)=k(n+k(i,4),5)+1

  460   CONTINUE

        iemp=0

        DO 470 i=n+1,n+njet

          IF(k(i,5).EQ.0) iemp=i

  470   CONTINUE

        IF(iemp.NE.0) THEN

          nloop=nloop+1

          ispl=0

          r2max=0d0

          DO 480 i=n+np+1,n+2*np

            IF(k(n+k(i,4),5).LE.1.OR.p(i,5).LT.rinit) goto 480

            ijet=n+k(i,4)

            r2=r2t(i,ijet)

            IF(r2.LE.r2max) goto 480

            ispl=i

            r2max=r2

  480     CONTINUE

          IF(ispl.NE.0) THEN

            ijet=n+k(ispl,4)

            DO 490 j=1,4

              p(iemp,j)=p(ispl,j)

              p(ijet,j)=p(ijet,j)-p(ispl,j)

  490       CONTINUE

            p(iemp,5)=p(ispl,5)

            p(ijet,5)=sqrt(p(ijet,1)**2+p(ijet,2)**2+p(ijet,3)**2)

            IF(nloop.LE.2) goto 300

          ENDIF

        ENDIF

      ENDIF


C...If generalized thrust has not yet converged, continue iteration.

      IF(mstu(46).LE.1.AND.nloop.LE.2.AND.psjt/pss.GT.tsav+paru(48))

     &THEN

        tsav=psjt/pss

        goto 310

      ENDIF


C...Reorder jets according to energy.

      DO 510 i=n+1,n+njet

        DO 500 j=1,5

          v(i,j)=p(i,j)

  500   CONTINUE

  510 CONTINUE

      DO 540 inew=n+1,n+njet

        pemax=0d0

        DO 520 itry=n+1,n+njet

          IF(v(itry,4).LE.pemax) goto 520

          imax=itry

          pemax=v(itry,4)

  520   CONTINUE

        k(inew,1)=31

        k(inew,2)=97

        k(inew,3)=inew-n

        k(inew,4)=0

        DO 530 j=1,5

          p(inew,j)=v(imax,j)

  530   CONTINUE

        v(imax,4)=-1d0

        k(imax,5)=inew

  540 CONTINUE


C...Clean up particle-jet assignments and jet information.

      DO 550 i=n+np+1,n+2*np

        iori=k(n+k(i,4),5)

        k(i,4)=iori-n

        IF(k(k(i,3),1).NE.3) k(k(i,3),4)=iori-n

        k(iori,4)=k(iori,4)+1

  550 CONTINUE

      iemp=0

      psjt=0d0

      DO 570 i=n+1,n+njet

        k(i,5)=0

        psjt=psjt+p(i,5)

        p(i,5)=sqrt(max(p(i,4)**2-p(i,5)**2,0d0))

        DO 560 j=1,5

          v(i,j)=0d0

  560   CONTINUE

        IF(k(i,4).EQ.0) iemp=i

  570 CONTINUE


C...Select storing option. Output variables. Check for failure.

      mstu(61)=n+1

      mstu(62)=np

      mstu(63)=npre

      paru(61)=ps(5)

      paru(62)=psjt/pss

      paru(63)=sqrt(r2min)

      IF(njet.LE.1) paru(63)=0d0

      IF(iemp.NE.0) THEN

        CALL pyerrm(8,'(PYCLUS:) failed to reconstruct as requested')

        njet=-1

      ENDIF

      IF(mstu(43).LE.1) mstu(3)=njet

      IF(mstu(43).GE.2) n=n+njet

      nsav=njet


      RETURN

      END


C*********************************************************************


C...PYCELL

C...Provides a simple way of jet finding in eta-phi-ET coordinates,

C...as used for calorimeters at hadron colliders.


      SUBROUTINE pycell(NJET)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Loop over all particles. Find cell that was hit by given particle.

      ptlrat=1d0/sinh(paru(51))**2

      np=0

      nc=n

      DO 110 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110

        IF(p(i,1)**2+p(i,2)**2.LE.ptlrat*p(i,3)**2) goto 110

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 110

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 110

        ENDIF

        np=np+1

        pt=sqrt(p(i,1)**2+p(i,2)**2)

        eta=sign(log((sqrt(pt**2+p(i,3)**2)+abs(p(i,3)))/pt),p(i,3))

        ieta=max(1,min(mstu(51),1+int(mstu(51)*0.5d0*

     &  (eta/paru(51)+1d0))))

        phi=pyangl(p(i,1),p(i,2))

        iphi=max(1,min(mstu(52),1+int(mstu(52)*0.5d0*

     &  (phi/paru(1)+1d0))))

        ietph=mstu(52)*ieta+iphi


C...Add to cell already hit, or book new cell.

        DO 100 ic=n+1,nc

          IF(ietph.EQ.k(ic,3)) THEN

            k(ic,4)=k(ic,4)+1

            p(ic,5)=p(ic,5)+pt

            goto 110

          ENDIF

  100   CONTINUE

        IF(nc.GE.mstu(4)-mstu(32)-5) THEN

          CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')

          njet=-2

          RETURN

        ENDIF

        nc=nc+1

        k(nc,3)=ietph

        k(nc,4)=1

        k(nc,5)=2

        p(nc,1)=(paru(51)/mstu(51))*(2*ieta-1-mstu(51))

        p(nc,2)=(paru(1)/mstu(52))*(2*iphi-1-mstu(52))

        p(nc,5)=pt

  110 CONTINUE


C...Smear true bin content by calorimeter resolution.

      IF(mstu(53).GE.1) THEN

        DO 130 ic=n+1,nc

          pei=p(ic,5)

          IF(mstu(53).EQ.2) pei=p(ic,5)*cosh(p(ic,1))

  120     pef=pei+paru(55)*sqrt(-2d0*log(max(1d-10,pyr(0)))*pei)*

     &    cos(paru(2)*pyr(0))

          IF(pef.LT.0d0.OR.pef.GT.paru(56)*pei) goto 120

          p(ic,5)=pef

          IF(mstu(53).EQ.2) p(ic,5)=pef/cosh(p(ic,1))

  130   CONTINUE

      ENDIF


C...Remove cells below threshold.

      IF(paru(58).GT.0d0) THEN

        ncc=nc

        nc=n

        DO 140 ic=n+1,ncc

          IF(p(ic,5).GT.paru(58)) THEN

            nc=nc+1

            k(nc,3)=k(ic,3)

            k(nc,4)=k(ic,4)

            k(nc,5)=k(ic,5)

            p(nc,1)=p(ic,1)

            p(nc,2)=p(ic,2)

            p(nc,5)=p(ic,5)

          ENDIF

  140   CONTINUE

      ENDIF


C...Find initiator cell: the one with highest pT of not yet used ones.

      nj=nc

  150 etmax=0d0

      DO 160 ic=n+1,nc

        IF(k(ic,5).NE.2) goto 160

        IF(p(ic,5).LE.etmax) goto 160

        icmax=ic

        eta=p(ic,1)

        phi=p(ic,2)

        etmax=p(ic,5)

  160 CONTINUE

      IF(etmax.LT.paru(52)) goto 220

      IF(nj.GE.mstu(4)-mstu(32)-5) THEN

        CALL pyerrm(11,'(PYCELL:) no more memory left in PYJETS')

        njet=-2

        RETURN

      ENDIF

      k(icmax,5)=1

      nj=nj+1

      k(nj,4)=0

      k(nj,5)=1

      p(nj,1)=eta

      p(nj,2)=phi

      p(nj,3)=0d0

      p(nj,4)=0d0

      p(nj,5)=0d0


C...Sum up unused cells within required distance of initiator.

      DO 170 ic=n+1,nc

        IF(k(ic,5).EQ.0) goto 170

        IF(abs(p(ic,1)-eta).GT.paru(54)) goto 170

        dphia=abs(p(ic,2)-phi)

        IF(dphia.GT.paru(54).AND.dphia.LT.paru(2)-paru(54)) goto 170

        phic=p(ic,2)

        IF(dphia.GT.paru(1)) phic=phic+sign(paru(2),phi)

        IF((p(ic,1)-eta)**2+(phic-phi)**2.GT.paru(54)**2) goto 170

        k(ic,5)=-k(ic,5)

        k(nj,4)=k(nj,4)+k(ic,4)

        p(nj,3)=p(nj,3)+p(ic,5)*p(ic,1)

        p(nj,4)=p(nj,4)+p(ic,5)*phic

        p(nj,5)=p(nj,5)+p(ic,5)

  170 CONTINUE


C...Reject cluster below minimum ET, else accept.

      IF(p(nj,5).LT.paru(53)) THEN

        nj=nj-1

        DO 180 ic=n+1,nc

          IF(k(ic,5).LT.0) k(ic,5)=-k(ic,5)

  180   CONTINUE

      ELSEIF(mstu(54).LE.2) THEN

        p(nj,3)=p(nj,3)/p(nj,5)

        p(nj,4)=p(nj,4)/p(nj,5)

        IF(abs(p(nj,4)).GT.paru(1)) p(nj,4)=p(nj,4)-sign(paru(2),

     &  p(nj,4))

        DO 190 ic=n+1,nc

          IF(k(ic,5).LT.0) k(ic,5)=0

  190   CONTINUE

      ELSE

        DO 200 j=1,4

          p(nj,j)=0d0

  200   CONTINUE

        DO 210 ic=n+1,nc

          IF(k(ic,5).GE.0) goto 210

          p(nj,1)=p(nj,1)+p(ic,5)*cos(p(ic,2))

          p(nj,2)=p(nj,2)+p(ic,5)*sin(p(ic,2))

          p(nj,3)=p(nj,3)+p(ic,5)*sinh(p(ic,1))

          p(nj,4)=p(nj,4)+p(ic,5)*cosh(p(ic,1))

          k(ic,5)=0

  210   CONTINUE

      ENDIF

      goto 150


C...Arrange clusters in falling ET sequence.

  220 DO 250 i=1,nj-nc

        etmax=0d0

        DO 230 ij=nc+1,nj

          IF(k(ij,5).EQ.0) goto 230

          IF(p(ij,5).LT.etmax) goto 230

          ijmax=ij

          etmax=p(ij,5)

  230   CONTINUE

        k(ijmax,5)=0

        k(n+i,1)=31

        k(n+i,2)=98

        k(n+i,3)=i

        k(n+i,4)=k(ijmax,4)

        k(n+i,5)=0

        DO 240 j=1,5

          p(n+i,j)=p(ijmax,j)

          v(n+i,j)=0d0

  240   CONTINUE

  250 CONTINUE

      njet=nj-nc


C...Convert to massless or massive four-vectors.

      IF(mstu(54).EQ.2) THEN

        DO 260 i=n+1,n+njet

          eta=p(i,3)

          p(i,1)=p(i,5)*cos(p(i,4))

          p(i,2)=p(i,5)*sin(p(i,4))

          p(i,3)=p(i,5)*sinh(eta)

          p(i,4)=p(i,5)*cosh(eta)

          p(i,5)=0d0

  260   CONTINUE

      ELSEIF(mstu(54).GE.3) THEN

        DO 270 i=n+1,n+njet

          p(i,5)=sqrt(max(0d0,p(i,4)**2-p(i,1)**2-p(i,2)**2-p(i,3)**2))

  270   CONTINUE

      ENDIF


C...Information about storage.

      mstu(61)=n+1

      mstu(62)=np

      mstu(63)=nc-n

      IF(mstu(43).LE.1) mstu(3)=njet

      IF(mstu(43).GE.2) n=n+njet


      RETURN

      END


C*********************************************************************


C...PYJMAS

C...Determines, approximately, the two jet masses that minimize

C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.


      SUBROUTINE pyjmas(PMH,PML)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/

C...Local arrays.

      dimension sm(3,3),sax(3),ps(3,5)


C...Reset.

      np=0

      DO 120 j1=1,3

        DO 100 j2=j1,3

          sm(j1,j2)=0d0

  100   CONTINUE

        DO 110 j2=1,4

          ps(j1,j2)=0d0

  110   CONTINUE

  120 CONTINUE

      pss=0d0

      pimass=pmas(pycomp(211),1)


C...Take copy of particles that are to be considered in mass analysis.

      DO 170 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 170

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 170

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 170

        ENDIF

        IF(n+np+1.GE.mstu(4)-mstu(32)-5) THEN

          CALL pyerrm(11,'(PYJMAS:) no more memory left in PYJETS')

          pmh=-2d0

          pml=-2d0

          RETURN

        ENDIF

        np=np+1

        DO 130 j=1,5

          p(n+np,j)=p(i,j)

  130   CONTINUE

        IF(mstu(42).EQ.0) p(n+np,5)=0d0

        IF(mstu(42).EQ.1.AND.k(i,2).NE.22) p(n+np,5)=pimass

        p(n+np,4)=sqrt(p(n+np,5)**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)


C...Fill information in sphericity tensor and total momentum vector.

        DO 150 j1=1,3

          DO 140 j2=j1,3

            sm(j1,j2)=sm(j1,j2)+p(i,j1)*p(i,j2)

  140     CONTINUE

  150   CONTINUE

        pss=pss+(p(i,1)**2+p(i,2)**2+p(i,3)**2)

        DO 160 j=1,4

          ps(3,j)=ps(3,j)+p(n+np,j)

  160   CONTINUE

  170 CONTINUE


C...Very low multiplicities (0 or 1) not considered.

      IF(np.LE.1) THEN

        CALL pyerrm(8,'(PYJMAS:) too few particles for analysis')

        pmh=-1d0

        pml=-1d0

        RETURN

      ENDIF

      paru(61)=sqrt(max(0d0,ps(3,4)**2-ps(3,1)**2-ps(3,2)**2-

     &ps(3,3)**2))


C...Find largest eigenvalue to matrix (third degree equation).

      DO 190 j1=1,3

        DO 180 j2=j1,3

          sm(j1,j2)=sm(j1,j2)/pss

  180   CONTINUE

  190 CONTINUE

      sq=(sm(1,1)*sm(2,2)+sm(1,1)*sm(3,3)+sm(2,2)*sm(3,3)-

     &sm(1,2)**2-sm(1,3)**2-sm(2,3)**2)/3d0-1d0/9d0

      sr=-0.5d0*(sq+1d0/9d0+sm(1,1)*sm(2,3)**2+sm(2,2)*sm(1,3)**2+

     &sm(3,3)*sm(1,2)**2-sm(1,1)*sm(2,2)*sm(3,3))+

     &sm(1,2)*sm(1,3)*sm(2,3)+1d0/27d0

      sp=cos(acos(max(min(sr/sqrt(-sq**3),1d0),-1d0))/3d0)

      sma=1d0/3d0+sqrt(-sq)*max(2d0*sp,sqrt(3d0*(1d0-sp**2))-sp)


C...Find largest eigenvector by solving equation system.

      DO 210 j1=1,3

        sm(j1,j1)=sm(j1,j1)-sma

        DO 200 j2=j1+1,3

          sm(j2,j1)=sm(j1,j2)

  200   CONTINUE

  210 CONTINUE

      smax=0d0

      DO 230 j1=1,3

        DO 220 j2=1,3

          IF(abs(sm(j1,j2)).LE.smax) goto 220

          ja=j1

          jb=j2

          smax=abs(sm(j1,j2))

  220   CONTINUE

  230 CONTINUE

      smax=0d0

      DO 250 j3=ja+1,ja+2

        j1=j3-3*((j3-1)/3)

        rl=sm(j1,jb)/sm(ja,jb)

        DO 240 j2=1,3

          sm(j1,j2)=sm(j1,j2)-rl*sm(ja,j2)

          IF(abs(sm(j1,j2)).LE.smax) goto 240

          jc=j1

          smax=abs(sm(j1,j2))

  240   CONTINUE

  250 CONTINUE

      jb1=jb+1-3*(jb/3)

      jb2=jb+2-3*((jb+1)/3)

      sax(jb1)=-sm(jc,jb2)

      sax(jb2)=sm(jc,jb1)

      sax(jb)=-(sm(ja,jb1)*sax(jb1)+sm(ja,jb2)*sax(jb2))/sm(ja,jb)


C...Divide particles into two initial clusters by hemisphere.

      DO 270 i=n+1,n+np

        psax=p(i,1)*sax(1)+p(i,2)*sax(2)+p(i,3)*sax(3)

        is=1

        IF(psax.LT.0d0) is=2

        k(i,3)=is

        DO 260 j=1,4

          ps(is,j)=ps(is,j)+p(i,j)

  260   CONTINUE

  270 CONTINUE

      pms=max(1d-10,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2)+

     &max(1d-10,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2)


C...Reassign one particle at a time; find maximum decrease of m^2 sum.

  280 pmd=0d0

      im=0

      DO 290 j=1,4

        ps(3,j)=ps(1,j)-ps(2,j)

  290 CONTINUE

      DO 300 i=n+1,n+np

        pps=p(i,4)*ps(3,4)-p(i,1)*ps(3,1)-p(i,2)*ps(3,2)-p(i,3)*ps(3,3)

        IF(k(i,3).EQ.1) pmdi=2d0*(p(i,5)**2-pps)

        IF(k(i,3).EQ.2) pmdi=2d0*(p(i,5)**2+pps)

        IF(pmdi.LT.pmd) THEN

          pmd=pmdi

          im=i

        ENDIF

  300 CONTINUE


C...Loop back if significant reduction in sum of m^2.

      IF(pmd.LT.-paru(48)*pms) THEN

        pms=pms+pmd

        is=k(im,3)

        DO 310 j=1,4

          ps(is,j)=ps(is,j)-p(im,j)

          ps(3-is,j)=ps(3-is,j)+p(im,j)

  310   CONTINUE

        k(im,3)=3-is

        goto 280

      ENDIF


C...Final masses and output.

      mstu(61)=n+1

      mstu(62)=np

      ps(1,5)=sqrt(max(0d0,ps(1,4)**2-ps(1,1)**2-ps(1,2)**2-ps(1,3)**2))

      ps(2,5)=sqrt(max(0d0,ps(2,4)**2-ps(2,1)**2-ps(2,2)**2-ps(2,3)**2))

      pmh=max(ps(1,5),ps(2,5))

      pml=min(ps(1,5),ps(2,5))


      RETURN

      END


C*********************************************************************


C...PYFOWO

C...Calculates the first few Fox-Wolfram moments.


      SUBROUTINE pyfowo(H10,H20,H30,H40)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Copy momenta for particles and calculate H0.

      np=0

      h0=0d0

      hd=0d0

      DO 110 i=1,n

        IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 110

        IF(mstu(41).GE.2) THEN

          kc=pycomp(k(i,2))

          IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &    kc.EQ.18) goto 110

          IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.pychge(k(i,2)).EQ.0)

     &    goto 110

        ENDIF

        IF(n+np.GE.mstu(4)-mstu(32)-5) THEN

          CALL pyerrm(11,'(PYFOWO:) no more memory left in PYJETS')

          h10=-1d0

          h20=-1d0

          h30=-1d0

          h40=-1d0

          RETURN

        ENDIF

        np=np+1

        DO 100 j=1,3

          p(n+np,j)=p(i,j)

  100   CONTINUE

        p(n+np,4)=sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2)

        h0=h0+p(n+np,4)

        hd=hd+p(n+np,4)**2

  110 CONTINUE

      h0=h0**2


C...Very low multiplicities (0 or 1) not considered.

      IF(np.LE.1) THEN

        CALL pyerrm(8,'(PYFOWO:) too few particles for analysis')

        h10=-1d0

        h20=-1d0

        h30=-1d0

        h40=-1d0

        RETURN

      ENDIF


C...Calculate H1 - H4.

      h10=0d0

      h20=0d0

      h30=0d0

      h40=0d0

      DO 130 i1=n+1,n+np

        DO 120 i2=i1+1,n+np

          cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/

     &    (p(i1,4)*p(i2,4))

          h10=h10+p(i1,4)*p(i2,4)*cthe

          h20=h20+p(i1,4)*p(i2,4)*(1.5d0*cthe**2-0.5d0)

          h30=h30+p(i1,4)*p(i2,4)*(2.5d0*cthe**3-1.5d0*cthe)

          h40=h40+p(i1,4)*p(i2,4)*(4.375d0*cthe**4-3.75d0*cthe**2+

     &    0.375d0)

  120   CONTINUE

  130 CONTINUE


C...Calculate H1/H0 - H4/H0. Output.

      mstu(61)=n+1

      mstu(62)=np

      h10=(hd+2d0*h10)/h0

      h20=(hd+2d0*h20)/h0

      h30=(hd+2d0*h30)/h0

      h40=(hd+2d0*h40)/h0


      RETURN

      END


C*********************************************************************


C...PYTABU

C...Evaluates various properties of an event, with statistics

C...accumulated during the course of the run and

C...printed at the end.


      SUBROUTINE pytabu(MTABU)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      common/pydat3/mdcy(500,3),mdme(4000,2),brat(4000),kfdp(4000,5)

      SAVE /pyjets/,/pydat1/,/pydat2/,/pydat3/

C...Local arrays, character variables, saved variables and data.

      dimension kfis(100,2),npis(100,0:10),kffs(400),npfs(400,4),

     &fevfm(10,4),fm1fm(3,10,4),fm2fm(3,10,4),fmoma(4),fmoms(4),

     &fevee(50),fe1ec(50),fe2ec(50),fe1ea(25),fe2ea(25),

     &kfdm(8),kfdc(200,0:8),npdc(200)

      SAVE nevis,nkfis,kfis,npis,nevfs,nprfs,nfifs,nchfs,nkffs,

     &kffs,npfs,nevfm,nmufm,fm1fm,fm2fm,nevee,fe1ec,fe2ec,fe1ea,

     &fe2ea,nevdc,nkfdc,nredc,kfdc,npdc

      CHARACTER chau*16,chis(2)*12,chdc(8)*12

      DATA nevis/0/,nkfis/0/,nevfs/0/,nprfs/0/,nfifs/0/,nchfs/0/,

     &nkffs/0/,nevfm/0/,nmufm/0/,fm1fm/120*0d0/,fm2fm/120*0d0/,

     &nevee/0/,fe1ec/50*0d0/,fe2ec/50*0d0/,fe1ea/25*0d0/,fe2ea/25*0d0/,

     &nevdc/0/,nkfdc/0/,nredc/0/


C...Reset statistics on initial parton state.

      IF(mtabu.EQ.10) THEN

        nevis=0

        nkfis=0


C...Identify and order flavour content of initial state.

      ELSEIF(mtabu.EQ.11) THEN

        nevis=nevis+1

        kfm1=2*iabs(mstu(161))

        IF(mstu(161).GT.0) kfm1=kfm1-1

        kfm2=2*iabs(mstu(162))

        IF(mstu(162).GT.0) kfm2=kfm2-1

        kfmn=min(kfm1,kfm2)

        kfmx=max(kfm1,kfm2)

        DO 100 i=1,nkfis

          IF(kfmn.EQ.kfis(i,1).AND.kfmx.EQ.kfis(i,2)) THEN

            ikfis=-i

            goto 110

          ELSEIF(kfmn.LT.kfis(i,1).OR.(kfmn.EQ.kfis(i,1).AND.

     &      kfmx.LT.kfis(i,2))) THEN

            ikfis=i

            goto 110

          ENDIF

  100   CONTINUE

        ikfis=nkfis+1

  110   IF(ikfis.LT.0) THEN

          ikfis=-ikfis

        ELSE

          IF(nkfis.GE.100) RETURN

          DO 130 i=nkfis,ikfis,-1

            kfis(i+1,1)=kfis(i,1)

            kfis(i+1,2)=kfis(i,2)

            DO 120 j=0,10

              npis(i+1,j)=npis(i,j)

  120       CONTINUE

  130     CONTINUE

          nkfis=nkfis+1

          kfis(ikfis,1)=kfmn

          kfis(ikfis,2)=kfmx

          DO 140 j=0,10

            npis(ikfis,j)=0

  140     CONTINUE

        ENDIF

        npis(ikfis,0)=npis(ikfis,0)+1


C...Count number of partons in initial state.

        np=0

        DO 160 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.12) THEN

          ELSEIF(iabs(k(i,2)).GT.80.AND.iabs(k(i,2)).LE.100) THEN

          ELSEIF(iabs(k(i,2)).GT.100.AND.mod(iabs(k(i,2))/10,10).NE.0)

     &      THEN

          ELSE

            im=i

  150       im=k(im,3)

            IF(im.LE.0.OR.im.GT.n) THEN

              np=np+1

            ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN

              np=np+1

            ELSEIF(iabs(k(im,2)).GT.80.AND.iabs(k(im,2)).LE.100) THEN

            ELSEIF(iabs(k(im,2)).GT.100.AND.mod(iabs(k(im,2))/10,10)

     &        .NE.0) THEN

            ELSE

              goto 150

            ENDIF

          ENDIF

  160   CONTINUE

        npco=max(np,1)

        IF(np.GE.6) npco=6

        IF(np.GE.8) npco=7

        IF(np.GE.11) npco=8

        IF(np.GE.16) npco=9

        IF(np.GE.26) npco=10

        npis(ikfis,npco)=npis(ikfis,npco)+1

        mstu(62)=np


C...Write statistics on initial parton state.

      ELSEIF(mtabu.EQ.12) THEN

        fac=1d0/max(1,nevis)

        WRITE(mstu(11),5000) nevis

        DO 170 i=1,nkfis

          kfmn=kfis(i,1)

          IF(kfmn.EQ.0) kfmn=kfis(i,2)

          kfm1=(kfmn+1)/2

          IF(2*kfm1.EQ.kfmn) kfm1=-kfm1

          CALL pyname(kfm1,chau)

          chis(1)=chau(1:12)

          IF(chau(13:13).NE.' ') chis(1)(12:12)='?'

          kfmx=kfis(i,2)

          IF(kfis(i,1).EQ.0) kfmx=0

          kfm2=(kfmx+1)/2

          IF(2*kfm2.EQ.kfmx) kfm2=-kfm2

          CALL pyname(kfm2,chau)

          chis(2)=chau(1:12)

          IF(chau(13:13).NE.' ') chis(2)(12:12)='?'

          WRITE(mstu(11),5100) chis(1),chis(2),fac*npis(i,0),

     &    (npis(i,j)/dble(npis(i,0)),j=1,10)

  170   CONTINUE


C...Copy statistics on initial parton state into /PYJETS/.

      ELSEIF(mtabu.EQ.13) THEN

        fac=1d0/max(1,nevis)

        DO 190 i=1,nkfis

          kfmn=kfis(i,1)

          IF(kfmn.EQ.0) kfmn=kfis(i,2)

          kfm1=(kfmn+1)/2

          IF(2*kfm1.EQ.kfmn) kfm1=-kfm1

          kfmx=kfis(i,2)

          IF(kfis(i,1).EQ.0) kfmx=0

          kfm2=(kfmx+1)/2

          IF(2*kfm2.EQ.kfmx) kfm2=-kfm2

          k(i,1)=32

          k(i,2)=99

          k(i,3)=kfm1

          k(i,4)=kfm2

          k(i,5)=npis(i,0)

          DO 180 j=1,5

            p(i,j)=fac*npis(i,j)

            v(i,j)=fac*npis(i,j+5)

  180     CONTINUE

  190   CONTINUE

        n=nkfis

        DO 200 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  200   CONTINUE

        k(n+1,1)=32

        k(n+1,2)=99

        k(n+1,5)=nevis

        mstu(3)=1


C...Reset statistics on number of particles/partons.

      ELSEIF(mtabu.EQ.20) THEN

        nevfs=0

        nprfs=0

        nfifs=0

        nchfs=0

        nkffs=0


C...Identify whether particle/parton is primary or not.

      ELSEIF(mtabu.EQ.21) THEN

        nevfs=nevfs+1

        mstu(62)=0

        DO 260 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.20.OR.k(i,1).EQ.13) goto 260

          mstu(62)=mstu(62)+1

          kc=pycomp(k(i,2))

          mpri=0

          IF(k(i,3).LE.0.OR.k(i,3).GT.n) THEN

            mpri=1

          ELSEIF(k(k(i,3),1).LE.0.OR.k(k(i,3),1).GT.20) THEN

            mpri=1

          ELSEIF(k(k(i,3),2).GE.91.AND.k(k(i,3),2).LE.93) THEN

            mpri=1

          ELSEIF(kc.EQ.0) THEN

          ELSEIF(k(k(i,3),1).EQ.13) THEN

            im=k(k(i,3),3)

            IF(im.LE.0.OR.im.GT.n) THEN

              mpri=1

            ELSEIF(k(im,1).LE.0.OR.k(im,1).GT.20) THEN

              mpri=1

            ENDIF

          ELSEIF(kchg(kc,2).EQ.0) THEN

            kcm=pycomp(k(k(i,3),2))

            IF(kcm.NE.0) THEN

              IF(kchg(kcm,2).NE.0) mpri=1

            ENDIF

          ENDIF

          IF(kc.NE.0.AND.mpri.EQ.1) THEN

            IF(kchg(kc,2).EQ.0) nprfs=nprfs+1

          ENDIF

          IF(k(i,1).LE.10) THEN

            nfifs=nfifs+1

            IF(pychge(k(i,2)).NE.0) nchfs=nchfs+1

          ENDIF


C...Fill statistics on number of particles/partons in event.

          kfa=iabs(k(i,2))

          kfs=3-isign(1,k(i,2))-mpri

          DO 210 ip=1,nkffs

            IF(kfa.EQ.kffs(ip)) THEN

              ikffs=-ip

              goto 220

            ELSEIF(kfa.LT.kffs(ip)) THEN

              ikffs=ip

              goto 220

            ENDIF

  210     CONTINUE

          ikffs=nkffs+1

  220     IF(ikffs.LT.0) THEN

            ikffs=-ikffs

          ELSE

            IF(nkffs.GE.400) RETURN

            DO 240 ip=nkffs,ikffs,-1

              kffs(ip+1)=kffs(ip)

              DO 230 j=1,4

                npfs(ip+1,j)=npfs(ip,j)

  230         CONTINUE

  240       CONTINUE

            nkffs=nkffs+1

            kffs(ikffs)=kfa

            DO 250 j=1,4

              npfs(ikffs,j)=0

  250       CONTINUE

          ENDIF

          npfs(ikffs,kfs)=npfs(ikffs,kfs)+1

  260   CONTINUE


C...Write statistics on particle/parton composition of events.

      ELSEIF(mtabu.EQ.22) THEN

        fac=1d0/max(1,nevfs)

        WRITE(mstu(11),5200) nevfs,fac*nprfs,fac*nfifs,fac*nchfs

        DO 270 i=1,nkffs

          CALL pyname(kffs(i),chau)

          kc=pycomp(kffs(i))

          mdcyf=0

          IF(kc.NE.0) mdcyf=mdcy(kc,1)

          WRITE(mstu(11),5300) kffs(i),chau,mdcyf,(fac*npfs(i,j),j=1,4),

     &    fac*(npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4))

  270   CONTINUE


C...Copy particle/parton composition information into /PYJETS/.

      ELSEIF(mtabu.EQ.23) THEN

        fac=1d0/max(1,nevfs)

        DO 290 i=1,nkffs

          k(i,1)=32

          k(i,2)=99

          k(i,3)=kffs(i)

          k(i,4)=0

          k(i,5)=npfs(i,1)+npfs(i,2)+npfs(i,3)+npfs(i,4)

          DO 280 j=1,4

            p(i,j)=fac*npfs(i,j)

            v(i,j)=0d0

  280     CONTINUE

          p(i,5)=fac*k(i,5)

          v(i,5)=0d0

  290   CONTINUE

        n=nkffs

        DO 300 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  300   CONTINUE

        k(n+1,1)=32

        k(n+1,2)=99

        k(n+1,5)=nevfs

        p(n+1,1)=fac*nprfs

        p(n+1,2)=fac*nfifs

        p(n+1,3)=fac*nchfs

        mstu(3)=1


C...Reset factorial moments statistics.

      ELSEIF(mtabu.EQ.30) THEN

        nevfm=0

        nmufm=0

        DO 330 im=1,3

          DO 320 ib=1,10

            DO 310 ip=1,4

              fm1fm(im,ib,ip)=0d0

              fm2fm(im,ib,ip)=0d0

  310       CONTINUE

  320     CONTINUE

  330   CONTINUE


C...Find particles to include, with (pion,pseudo)rapidity and azimuth.

      ELSEIF(mtabu.EQ.31) THEN

        nevfm=nevfm+1

        nlow=n+mstu(3)

        nupp=nlow

        DO 410 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 410

          IF(mstu(41).GE.2) THEN

            kc=pycomp(k(i,2))

            IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &      kc.EQ.18) goto 410

            IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.

     &      pychge(k(i,2)).EQ.0) goto 410

          ENDIF

          pmr=0d0

          IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)

          IF(mstu(42).GE.2) pmr=p(i,5)

          pr=max(1d-20,pmr**2+p(i,1)**2+p(i,2)**2)

          yeta=sign(log(min((sqrt(pr+p(i,3)**2)+abs(p(i,3)))/sqrt(pr),

     &    1d20)),p(i,3))

          IF(abs(yeta).GT.paru(57)) goto 410

          phi=pyangl(p(i,1),p(i,2))

          iyeta=512d0*(yeta+paru(57))/(2d0*paru(57))

          iyeta=max(0,min(511,iyeta))

          iphi=512d0*(phi+paru(1))/paru(2)

          iphi=max(0,min(511,iphi))

          iyep=0

          DO 340 ib=0,9

            iyep=iyep+4**ib*(2*mod(iyeta/2**ib,2)+mod(iphi/2**ib,2))

  340     CONTINUE


C...Order particles in (pseudo)rapidity and/or azimuth.

          IF(nupp.GT.mstu(4)-5-mstu(32)) THEN

            CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')

            RETURN

          ENDIF

          nupp=nupp+1

          IF(nupp.EQ.nlow+1) THEN

            k(nupp,1)=iyeta

            k(nupp,2)=iphi

            k(nupp,3)=iyep

          ELSE

            DO 350 i1=nupp-1,nlow+1,-1

              IF(iyeta.GE.k(i1,1)) goto 360

              k(i1+1,1)=k(i1,1)

  350       CONTINUE

  360       k(i1+1,1)=iyeta

            DO 370 i1=nupp-1,nlow+1,-1

              IF(iphi.GE.k(i1,2)) goto 380

              k(i1+1,2)=k(i1,2)

  370       CONTINUE

  380       k(i1+1,2)=iphi

            DO 390 i1=nupp-1,nlow+1,-1

              IF(iyep.GE.k(i1,3)) goto 400

              k(i1+1,3)=k(i1,3)

  390       CONTINUE

  400       k(i1+1,3)=iyep

          ENDIF

  410   CONTINUE

        k(nupp+1,1)=2**10

        k(nupp+1,2)=2**10

        k(nupp+1,3)=4**10


C...Calculate sum of factorial moments in event.

        DO 480 im=1,3

          DO 430 ib=1,10

            DO 420 ip=1,4

              fevfm(ib,ip)=0d0

  420       CONTINUE

  430     CONTINUE

          DO 450 ib=1,10

            IF(im.LE.2) ibin=2**(10-ib)

            IF(im.EQ.3) ibin=4**(10-ib)

            iagr=k(nlow+1,im)/ibin

            nagr=1

            DO 440 i=nlow+2,nupp+1

              icut=k(i,im)/ibin

              IF(icut.EQ.iagr) THEN

                nagr=nagr+1

              ELSE

                IF(nagr.EQ.1) THEN

                ELSEIF(nagr.EQ.2) THEN

                  fevfm(ib,1)=fevfm(ib,1)+2d0

                ELSEIF(nagr.EQ.3) THEN

                  fevfm(ib,1)=fevfm(ib,1)+6d0

                  fevfm(ib,2)=fevfm(ib,2)+6d0

                ELSEIF(nagr.EQ.4) THEN

                  fevfm(ib,1)=fevfm(ib,1)+12d0

                  fevfm(ib,2)=fevfm(ib,2)+24d0

                  fevfm(ib,3)=fevfm(ib,3)+24d0

                ELSE

                  fevfm(ib,1)=fevfm(ib,1)+nagr*(nagr-1d0)

                  fevfm(ib,2)=fevfm(ib,2)+nagr*(nagr-1d0)*(nagr-2d0)

                  fevfm(ib,3)=fevfm(ib,3)+nagr*(nagr-1d0)*(nagr-2d0)*

     &            (nagr-3d0)

                  fevfm(ib,4)=fevfm(ib,4)+nagr*(nagr-1d0)*(nagr-2d0)*

     &            (nagr-3d0)*(nagr-4d0)

                ENDIF

                iagr=icut

                nagr=1

              ENDIF

  440       CONTINUE

  450     CONTINUE


C...Add results to total statistics.

          DO 470 ib=10,1,-1

            DO 460 ip=1,4

              IF(fevfm(1,ip).LT.0.5d0) THEN

                fevfm(ib,ip)=0d0

              ELSEIF(im.LE.2) THEN

                fevfm(ib,ip)=2d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)

              ELSE

                fevfm(ib,ip)=4d0**((ib-1)*ip)*fevfm(ib,ip)/fevfm(1,ip)

              ENDIF

              fm1fm(im,ib,ip)=fm1fm(im,ib,ip)+fevfm(ib,ip)

              fm2fm(im,ib,ip)=fm2fm(im,ib,ip)+fevfm(ib,ip)**2

  460       CONTINUE

  470     CONTINUE

  480   CONTINUE

        nmufm=nmufm+(nupp-nlow)

        mstu(62)=nupp-nlow


C...Write accumulated statistics on factorial moments.

      ELSEIF(mtabu.EQ.32) THEN

        fac=1d0/max(1,nevfm)

        IF(mstu(42).LE.0) WRITE(mstu(11),5400) nevfm,'eta'

        IF(mstu(42).EQ.1) WRITE(mstu(11),5400) nevfm,'ypi'

        IF(mstu(42).GE.2) WRITE(mstu(11),5400) nevfm,'y  '

        DO 510 im=1,3

          WRITE(mstu(11),5500)

          DO 500 ib=1,10

            byeta=2d0*paru(57)

            IF(im.NE.2) byeta=byeta/2**(ib-1)

            bphi=paru(2)

            IF(im.NE.1) bphi=bphi/2**(ib-1)

            IF(im.LE.2) bnave=fac*nmufm/dble(2**(ib-1))

            IF(im.EQ.3) bnave=fac*nmufm/dble(4**(ib-1))

            DO 490 ip=1,4

              fmoma(ip)=fac*fm1fm(im,ib,ip)

              fmoms(ip)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-

     &        fmoma(ip)**2)))

  490       CONTINUE

            WRITE(mstu(11),5600) byeta,bphi,bnave,(fmoma(ip),fmoms(ip),

     &      ip=1,4)

  500     CONTINUE

  510   CONTINUE


C...Copy statistics on factorial moments into /PYJETS/.

      ELSEIF(mtabu.EQ.33) THEN

        fac=1d0/max(1,nevfm)

        DO 540 im=1,3

          DO 530 ib=1,10

            i=10*(im-1)+ib

            k(i,1)=32

            k(i,2)=99

            k(i,3)=1

            IF(im.NE.2) k(i,3)=2**(ib-1)

            k(i,4)=1

            IF(im.NE.1) k(i,4)=2**(ib-1)

            k(i,5)=0

            p(i,1)=2d0*paru(57)/k(i,3)

            v(i,1)=paru(2)/k(i,4)

            DO 520 ip=1,4

              p(i,ip+1)=fac*fm1fm(im,ib,ip)

              v(i,ip+1)=sqrt(max(0d0,fac*(fac*fm2fm(im,ib,ip)-

     &        p(i,ip+1)**2)))

  520       CONTINUE

  530     CONTINUE

  540   CONTINUE

        n=30

        DO 550 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  550   CONTINUE

        k(n+1,1)=32

        k(n+1,2)=99

        k(n+1,5)=nevfm

        mstu(3)=1


C...Reset statistics on Energy-Energy Correlation.

      ELSEIF(mtabu.EQ.40) THEN

        nevee=0

        DO 560 j=1,25

          fe1ec(j)=0d0

          fe2ec(j)=0d0

          fe1ec(51-j)=0d0

          fe2ec(51-j)=0d0

          fe1ea(j)=0d0

          fe2ea(j)=0d0

  560   CONTINUE


C...Find particles to include, with proper assumed mass.

      ELSEIF(mtabu.EQ.41) THEN

        nevee=nevee+1

        nlow=n+mstu(3)

        nupp=nlow

        ecm=0d0

        DO 570 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GT.10) goto 570

          IF(mstu(41).GE.2) THEN

            kc=pycomp(k(i,2))

            IF(kc.EQ.0.OR.kc.EQ.12.OR.kc.EQ.14.OR.kc.EQ.16.OR.

     &      kc.EQ.18) goto 570

            IF(mstu(41).GE.3.AND.kchg(kc,2).EQ.0.AND.

     &      pychge(k(i,2)).EQ.0) goto 570

          ENDIF

          pmr=0d0

          IF(mstu(42).EQ.1.AND.k(i,2).NE.22) pmr=pymass(211)

          IF(mstu(42).GE.2) pmr=p(i,5)

          IF(nupp.GT.mstu(4)-5-mstu(32)) THEN

            CALL pyerrm(11,'(PYTABU:) no more memory left in PYJETS')

            RETURN

          ENDIF

          nupp=nupp+1

          p(nupp,1)=p(i,1)

          p(nupp,2)=p(i,2)

          p(nupp,3)=p(i,3)

          p(nupp,4)=sqrt(pmr**2+p(i,1)**2+p(i,2)**2+p(i,3)**2)

          p(nupp,5)=max(1d-10,sqrt(p(i,1)**2+p(i,2)**2+p(i,3)**2))

          ecm=ecm+p(nupp,4)

  570   CONTINUE

        IF(nupp.EQ.nlow) RETURN


C...Analyze Energy-Energy Correlation in event.

        fac=(2d0/ecm**2)*50d0/paru(1)

        DO 580 j=1,50

          fevee(j)=0d0

  580   CONTINUE

        DO 600 i1=nlow+2,nupp

          DO 590 i2=nlow+1,i1-1

            cthe=(p(i1,1)*p(i2,1)+p(i1,2)*p(i2,2)+p(i1,3)*p(i2,3))/

     &      (p(i1,5)*p(i2,5))

            the=acos(max(-1d0,min(1d0,cthe)))

            ithe=max(1,min(50,1+int(50d0*the/paru(1))))

            fevee(ithe)=fevee(ithe)+fac*p(i1,4)*p(i2,4)

  590     CONTINUE

  600   CONTINUE

        DO 610 j=1,25

          fe1ec(j)=fe1ec(j)+fevee(j)

          fe2ec(j)=fe2ec(j)+fevee(j)**2

          fe1ec(51-j)=fe1ec(51-j)+fevee(51-j)

          fe2ec(51-j)=fe2ec(51-j)+fevee(51-j)**2

          fe1ea(j)=fe1ea(j)+(fevee(51-j)-fevee(j))

          fe2ea(j)=fe2ea(j)+(fevee(51-j)-fevee(j))**2

  610   CONTINUE

        mstu(62)=nupp-nlow


C...Write statistics on Energy-Energy Correlation.

      ELSEIF(mtabu.EQ.42) THEN

        fac=1d0/max(1,nevee)

        WRITE(mstu(11),5700) nevee

        DO 620 j=1,25

          feec1=fac*fe1ec(j)

          fees1=sqrt(max(0d0,fac*(fac*fe2ec(j)-feec1**2)))

          feec2=fac*fe1ec(51-j)

          fees2=sqrt(max(0d0,fac*(fac*fe2ec(51-j)-feec2**2)))

          feeca=fac*fe1ea(j)

          feesa=sqrt(max(0d0,fac*(fac*fe2ea(j)-feeca**2)))

          WRITE(mstu(11),5800) 3.6d0*(j-1),3.6d0*j,feec1,fees1,

     &    feec2,fees2,feeca,feesa

  620   CONTINUE


C...Copy statistics on Energy-Energy Correlation into /PYJETS/.

      ELSEIF(mtabu.EQ.43) THEN

        fac=1d0/max(1,nevee)

        DO 630 i=1,25

          k(i,1)=32

          k(i,2)=99

          k(i,3)=0

          k(i,4)=0

          k(i,5)=0

          p(i,1)=fac*fe1ec(i)

          v(i,1)=sqrt(max(0d0,fac*(fac*fe2ec(i)-p(i,1)**2)))

          p(i,2)=fac*fe1ec(51-i)

          v(i,2)=sqrt(max(0d0,fac*(fac*fe2ec(51-i)-p(i,2)**2)))

          p(i,3)=fac*fe1ea(i)

          v(i,3)=sqrt(max(0d0,fac*(fac*fe2ea(i)-p(i,3)**2)))

          p(i,4)=paru(1)*(i-1)/50d0

          p(i,5)=paru(1)*i/50d0

          v(i,4)=3.6d0*(i-1)

          v(i,5)=3.6d0*i

  630   CONTINUE

        n=25

        DO 640 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  640   CONTINUE

        k(n+1,1)=32

        k(n+1,2)=99

        k(n+1,5)=nevee

        mstu(3)=1


C...Reset statistics on decay channels.

      ELSEIF(mtabu.EQ.50) THEN

        nevdc=0

        nkfdc=0

        nredc=0


C...Identify and order flavour content of final state.

      ELSEIF(mtabu.EQ.51) THEN

        nevdc=nevdc+1

        nds=0

        DO 670 i=1,n

          IF(k(i,1).LE.0.OR.k(i,1).GE.6) goto 670

          nds=nds+1

          IF(nds.GT.8) THEN

            nredc=nredc+1

            RETURN

          ENDIF

          kfm=2*iabs(k(i,2))

          IF(k(i,2).LT.0) kfm=kfm-1

          DO 650 ids=nds-1,1,-1

            iin=ids+1

            IF(kfm.LT.kfdm(ids)) goto 660

            kfdm(ids+1)=kfdm(ids)

  650     CONTINUE

          iin=1

  660     kfdm(iin)=kfm

  670   CONTINUE


C...Find whether old or new final state.

        DO 690 idc=1,nkfdc

          IF(nds.LT.kfdc(idc,0)) THEN

            ikfdc=idc

            goto 700

          ELSEIF(nds.EQ.kfdc(idc,0)) THEN

            DO 680 i=1,nds

              IF(kfdm(i).LT.kfdc(idc,i)) THEN

                ikfdc=idc

                goto 700

              ELSEIF(kfdm(i).GT.kfdc(idc,i)) THEN

                goto 690

              ENDIF

  680       CONTINUE

            ikfdc=-idc

            goto 700

          ENDIF

  690   CONTINUE

        ikfdc=nkfdc+1

  700   IF(ikfdc.LT.0) THEN

          ikfdc=-ikfdc

        ELSEIF(nkfdc.GE.200) THEN

          nredc=nredc+1

          RETURN

        ELSE

          DO 720 idc=nkfdc,ikfdc,-1

            npdc(idc+1)=npdc(idc)

            DO 710 i=0,8

              kfdc(idc+1,i)=kfdc(idc,i)

  710       CONTINUE

  720     CONTINUE

          nkfdc=nkfdc+1

          kfdc(ikfdc,0)=nds

          DO 730 i=1,nds

            kfdc(ikfdc,i)=kfdm(i)

  730     CONTINUE

          npdc(ikfdc)=0

        ENDIF

        npdc(ikfdc)=npdc(ikfdc)+1


C...Write statistics on decay channels.

      ELSEIF(mtabu.EQ.52) THEN

        fac=1d0/max(1,nevdc)

        WRITE(mstu(11),5900) nevdc

        DO 750 idc=1,nkfdc

          DO 740 i=1,kfdc(idc,0)

            kfm=kfdc(idc,i)

            kf=(kfm+1)/2

            IF(2*kf.NE.kfm) kf=-kf

            CALL pyname(kf,chau)

            chdc(i)=chau(1:12)

            IF(chau(13:13).NE.' ') chdc(i)(12:12)='?'

  740     CONTINUE

          WRITE(mstu(11),6000) fac*npdc(idc),(chdc(i),i=1,kfdc(idc,0))

  750   CONTINUE

        IF(nredc.NE.0) WRITE(mstu(11),6100) fac*nredc


C...Copy statistics on decay channels into /PYJETS/.

      ELSEIF(mtabu.EQ.53) THEN

        fac=1d0/max(1,nevdc)

        DO 780 idc=1,nkfdc

          k(idc,1)=32

          k(idc,2)=99

          k(idc,3)=0

          k(idc,4)=0

          k(idc,5)=kfdc(idc,0)

          DO 760 j=1,5

            p(idc,j)=0d0

            v(idc,j)=0d0

  760     CONTINUE

          DO 770 i=1,kfdc(idc,0)

            kfm=kfdc(idc,i)

            kf=(kfm+1)/2

            IF(2*kf.NE.kfm) kf=-kf

            IF(i.LE.5) p(idc,i)=kf

            IF(i.GE.6) v(idc,i-5)=kf

  770     CONTINUE

          v(idc,5)=fac*npdc(idc)

  780   CONTINUE

        n=nkfdc

        DO 790 j=1,5

          k(n+1,j)=0

          p(n+1,j)=0d0

          v(n+1,j)=0d0

  790   CONTINUE

        k(n+1,1)=32

        k(n+1,2)=99

        k(n+1,5)=nevdc

        v(n+1,5)=fac*nredc

        mstu(3)=1

      ENDIF


C...Format statements for output on unit MSTU(11) (default 6).

 5000 FORMAT(///20x,'Event statistics - initial state'/

     &20x,'based on an analysis of ',i6,' events'//

     &3x,'Main flavours after',8x,'Fraction',4x,'Subfractions ',

     &'according to fragmenting system multiplicity'/

     &4x,'hard interaction',24x,'1',7x,'2',7x,'3',7x,'4',7x,'5',

     &6x,'6-7',5x,'8-10',3x,'11-15',3x,'16-25',4x,'>25'/)

 5100 FORMAT(3x,a12,1x,a12,f10.5,1x,10f8.4)

 5200 FORMAT(///20x,'Event statistics - final state'/

     &20x,'based on an analysis of ',i7,' events'//

     &5x,'Mean primary multiplicity =',f10.4/

     &5x,'Mean final   multiplicity =',f10.4/

     &5x,'Mean charged multiplicity =',f10.4//

     &5x,'Number of particles produced per event (directly and via ',

     &'decays/branchings)'/

     &8x,'KF    Particle/jet  MDCY',10x,'Particles',13x,'Antiparticles',

     &8x,'Total'/35x,'prim        seco        prim        seco'/)

 5300 FORMAT(1x,i9,4x,a16,i2,5(1x,f11.6))

 5400 FORMAT(///20x,'Factorial moments analysis of multiplicity'/

     &20x,'based on an analysis of ',i6,' events'//

     &3x,'delta-',a3,' delta-phi     <n>/bin',10x,'<F2>',18x,'<F3>',

     &18x,'<F4>',18x,'<F5>'/35x,4('     value     error  '))

 5500 FORMAT(10x)

 5600 FORMAT(2x,2f10.4,f12.4,4(f12.4,f10.4))

 5700 FORMAT(///20x,'Energy-Energy Correlation and Asymmetry'/

     &20x,'based on an analysis of ',i6,' events'//

     &2x,'theta range',8x,'EEC(theta)',8x,'EEC(180-theta)',7x,

     &'EECA(theta)'/2x,'in degrees ',3('      value    error')/)

 5800 FORMAT(2x,f4.1,' - ',f4.1,3(f11.4,f9.4))

 5900 FORMAT(///20x,'Decay channel analysis - final state'/

     &20x,'based on an analysis of ',i6,' events'//

     &2x,'Probability',10x,'Complete final state'/)

 6000 FORMAT(2x,f9.5,5x,8(a12,1x))

 6100 FORMAT(2x,f9.5,5x,'into other channels (more than 8 particles ',

     &'or table overflow)')


      RETURN

      END


C*********************************************************************


C...PYEEVT

C...Handles the generation of an e+e- annihilation jet event.


      SUBROUTINE pyeevt(KFL,ECM)

C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Check input parameters.

      IF(mstu(12).GE.1) CALL pylist(0)

      IF(kfl.LT.0.OR.kfl.GT.8) THEN

        CALL pyerrm(16,'(PYEEVT:) called with unknown flavour code')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(kfl.LE.5) ecmmin=parj(127)+2.02d0*parf(100+max(1,kfl))

      IF(kfl.GE.6) ecmmin=parj(127)+2.02d0*pmas(kfl,1)

      IF(ecm.LT.ecmmin) THEN

        CALL pyerrm(16,'(PYEEVT:) called with too small CM energy')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Check consistency of MSTJ options set.

      IF(mstj(109).EQ.2.AND.mstj(110).NE.1) THEN

        CALL pyerrm(6,

     &  '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')

        mstj(110)=1

      ENDIF

      IF(mstj(109).EQ.2.AND.mstj(111).NE.0) THEN

        CALL pyerrm(6,

     &  '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')

        mstj(111)=0

      ENDIF


C...Initialize alpha_strong and total cross-section.

      mstu(111)=mstj(108)

      IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))

     &mstu(111)=1

      paru(112)=parj(121)

      IF(mstu(111).EQ.2) paru(112)=parj(122)

      IF(mstj(116).GT.0.AND.(mstj(116).GE.2.OR.abs(ecm-parj(151)).GE.

     &parj(139).OR.10*mstj(102)+kfl.NE.mstj(119))) CALL pyxtee(kfl,ecm,

     &xtot)

      IF(mstj(116).GE.3) mstj(116)=1

      parj(171)=0d0


C...Add initial e+e- to event record (documentation only).

      ntry=0

  100 ntry=ntry+1

      IF(ntry.GT.100) THEN

        CALL pyerrm(14,'(PYEEVT:) caught in an infinite loop')

        RETURN

      ENDIF

      mstu(24)=0

      nc=0

      IF(mstj(115).GE.2) THEN

        nc=nc+2

        CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)

        k(nc-1,1)=21

        CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)

        k(nc,1)=21

      ENDIF


C...Radiative photon (in initial state).

      mk=0

      ecmc=ecm

      IF(mstj(107).GE.1.AND.mstj(116).GE.1) CALL pyradk(ecm,mk,pak,

     &thek,phik,alpk)

      IF(mk.EQ.1) ecmc=sqrt(ecm*(ecm-2d0*pak))

      IF(mstj(115).GE.1.AND.mk.EQ.1) THEN

        nc=nc+1

        CALL py1ent(nc,22,pak,thek,phik)

        k(nc,3)=min(mstj(115)/2,1)

      ENDIF


C...Virtual exchange boson (gamma or Z0).

      IF(mstj(115).GE.3) THEN

        nc=nc+1

        kf=22

        IF(mstj(102).EQ.2) kf=23

        mstu10=mstu(10)

        mstu(10)=1

        p(nc,5)=ecmc

        CALL py1ent(nc,kf,ecmc,0d0,0d0)

        k(nc,1)=21

        k(nc,3)=1

        mstu(10)=mstu10

      ENDIF


C...Choice of flavour and jet configuration.

      CALL pyxkfl(kfl,ecm,ecmc,kflc)

      IF(kflc.EQ.0) goto 100

      CALL pyxjet(ecmc,njet,cut)

      kfln=21

      IF(njet.EQ.4) CALL pyx4jt(njet,cut,kflc,ecmc,kfln,x1,x2,x4,

     &x12,x14)

      IF(njet.EQ.3) CALL pyx3jt(njet,cut,kflc,ecmc,x1,x3)

      IF(njet.EQ.2) mstj(120)=1


C...Fill jet configuration and origin.

      IF(njet.EQ.2.AND.mstj(101).NE.5) CALL py2ent(nc+1,kflc,-kflc,ecmc)

      IF(njet.EQ.2.AND.mstj(101).EQ.5) CALL py2ent(-(nc+1),kflc,-kflc,

     &ecmc)

      IF(njet.EQ.3) CALL py3ent(nc+1,kflc,21,-kflc,ecmc,x1,x3)

      IF(njet.EQ.4.AND.kfln.EQ.21) CALL py4ent(nc+1,kflc,kfln,kfln,

     &-kflc,ecmc,x1,x2,x4,x12,x14)

      IF(njet.EQ.4.AND.kfln.NE.21) CALL py4ent(nc+1,kflc,-kfln,kfln,

     &-kflc,ecmc,x1,x2,x4,x12,x14)

      IF(mstu(24).NE.0) goto 100

      DO 110 ip=nc+1,n

        k(ip,3)=k(ip,3)+min(mstj(115)/2,1)+(mstj(115)/3)*(nc-1)

  110 CONTINUE


C...Angular orientation according to matrix element.

      IF(mstj(106).EQ.1) THEN

        CALL pyxdif(nc,njet,kflc,ecmc,chi,the,phi)

        CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)

        CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)

      ENDIF


C...Rotation and boost from radiative photon.

      IF(mk.EQ.1) THEN

        dbek=-pak/(ecm-pak)

        nmin=nc+1-mstj(115)/3

        CALL pyrobo(nmin,n,0d0,-phik,0d0,0d0,0d0)

        CALL pyrobo(nmin,n,alpk,0d0,dbek*sin(thek),0d0,dbek*cos(thek))

        CALL pyrobo(nmin,n,0d0,phik,0d0,0d0,0d0)

      ENDIF


C...Generate parton shower. Rearrange along strings and check.

      IF(mstj(101).EQ.5) THEN

        CALL pyshow(n-1,n,ecmc)

        mstj14=mstj(14)

        IF(mstj(105).EQ.-1) mstj(14)=-1

        IF(mstj(105).GE.0) mstu(28)=0

        CALL pyprep(0)

        mstj(14)=mstj14

        IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100

      ENDIF


C...Fragmentation/decay generation. Information for PYTABU.

      IF(mstj(105).EQ.1) CALL pyexec

      mstu(161)=kflc

      mstu(162)=-kflc


      RETURN

      END


C*********************************************************************


C...PYXTEE

C...Calculates total cross-section, including initial state

C...radiation effects.


      SUBROUTINE pyxtee(KFL,ECM,XTOT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Status, (optimized) Q^2 scale, alpha_strong.

      parj(151)=ecm

      mstj(119)=10*mstj(102)+kfl

      IF(mstj(111).EQ.0) THEN

        q2r=ecm**2

      ELSEIF(mstu(111).EQ.0) THEN

        parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/

     &  ((33d0-2d0*mstu(112))*paru(111)))))

        q2r=parj(168)*ecm**2

      ELSE

        parj(168)=min(1d0,max(parj(128),paru(112)/ecm,

     &  (2d0*paru(112)/ecm)**2))

        q2r=parj(168)*ecm**2

      ENDIF

      alspi=pyalps(q2r)/paru(1)


C...QCD corrections factor in R.

      IF(mstj(101).EQ.0.OR.mstj(109).EQ.1) THEN

        rqcd=1d0

      ELSEIF(iabs(mstj(101)).EQ.1.AND.mstj(109).EQ.0) THEN

        rqcd=1d0+alspi

      ELSEIF(mstj(109).EQ.0) THEN

        rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2

        IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+(33d0-2d0*mstu(112))/12d0*

     &  log(parj(168))*alspi**2)

      ELSEIF(iabs(mstj(101)).EQ.1) THEN

        rqcd=1d0+(3d0/4d0)*alspi

      ELSE

        rqcd=1d0+(3d0/4d0)*alspi-(3d0/32d0+0.519d0*mstu(118))*alspi**2

      ENDIF


C...Calculate Z0 width if default value not acceptable.

      IF(mstj(102).GE.3) THEN

        rva=3d0*(3d0+(4d0*paru(102)-1d0)**2)+6d0*rqcd*(2d0+

     &  (1d0-8d0*paru(102)/3d0)**2+(4d0*paru(102)/3d0-1d0)**2)

        DO 100 kflc=5,6

          vq=1d0

          IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-

     &    (2d0*pymass(kflc)/ ecm)**2))

          IF(kflc.EQ.5) vf=4d0*paru(102)/3d0-1d0

          IF(kflc.EQ.6) vf=1d0-8d0*paru(102)/3d0

          rva=rva+3d0*rqcd*(0.5d0*vq*(3d0-vq**2)*vf**2+vq**3)

  100   CONTINUE

        parj(124)=paru(101)*parj(123)*rva/(48d0*paru(102)*

     &  (1d0-paru(102)))

      ENDIF


C...Calculate propagator and related constants for QFD case.

      poll=1d0-parj(131)*parj(132)

      IF(mstj(102).GE.2) THEN

        sff=1d0/(16d0*paru(102)*(1d0-paru(102)))

        sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)

        sfi=sfw*(1d0-(parj(123)/ecm)**2)

        ve=4d0*paru(102)-1d0

        sf1i=sff*(ve*poll+parj(132)-parj(131))

        sf1w=sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))

        hf1i=sfi*sf1i

        hf1w=sfw*sf1w

      ENDIF


C...Loop over different flavours: charge, velocity.

      rtot=0d0

      rqq=0d0

      rqv=0d0

      rva=0d0

      DO 110 kflc=1,max(mstj(104),kfl)

        IF(kfl.GT.0.AND.kflc.NE.kfl) goto 110

        mstj(93)=1

        pmq=pymass(kflc)

        IF(ecm.LT.2d0*pmq+parj(127)) goto 110

        qf=kchg(kflc,1)/3d0

        vq=1d0

        IF(mod(mstj(103),2).EQ.1) vq=sqrt(1d0-(2d0*pmq/ecm)**2)


C...Calculate R and sum of charges for QED or QFD case.

        rqq=rqq+3d0*qf**2*poll

        IF(mstj(102).LE.1) THEN

          rtot=rtot+3d0*0.5d0*vq*(3d0-vq**2)*qf**2*poll

        ELSE

          vf=sign(1d0,qf)-4d0*qf*paru(102)

          rqv=rqv-6d0*qf*vf*sf1i

          rva=rva+3d0*(vf**2+1d0)*sf1w

          rtot=rtot+3d0*(0.5d0*vq*(3d0-vq**2)*(qf**2*poll-

     &    2d0*qf*vf*hf1i+vf**2*hf1w)+vq**3*hf1w)

        ENDIF

  110 CONTINUE

      rsum=rqq

      IF(mstj(102).GE.2) rsum=rqq+sfi*rqv+sfw*rva


C...Calculate cross-section, including QCD corrections.

      parj(141)=rqq

      parj(142)=rtot

      parj(143)=rtot*rqcd

      parj(144)=parj(143)

      parj(145)=parj(141)*86.8d0/ecm**2

      parj(146)=parj(142)*86.8d0/ecm**2

      parj(147)=parj(143)*86.8d0/ecm**2

      parj(148)=parj(147)

      parj(157)=rsum*rqcd

      parj(158)=0d0

      parj(159)=0d0

      xtot=parj(147)

      IF(mstj(107).LE.0) RETURN


C...Virtual cross-section.

      xkl=parj(135)

      xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)

      ale=2d0*log(ecm/pymass(11))-1d0

      sigv=ale/3d0+2d0*log(ecm**2/(pymass(13)*pymass(15)))/3d0-4d0/3d0+

     &1.526d0*log(ecm**2/0.932d0)


C...Soft and hard radiative cross-section in QED case.

      IF(mstj(102).LE.1) THEN

        sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+2d0*sigv

        sigs=ale*(2d0*log(xkl)-log(1d0-xkl)-xkl)

        sigh=ale*(2d0*log(xku/xkl)-log((1d0-xku)/(1d0-xkl))-(xku-xkl))


C...Soft and hard radiative cross-section in QFD case.

      ELSE

        szm=1d0-(parj(123)/ecm)**2

        szw=parj(123)*parj(124)/ecm**2

        parj(161)=-rqq/rsum

        parj(162)=-(rqq+rqv+rva)/rsum

        parj(163)=(rqv*(1d0-0.5d0*szm-sfi)+rva*(1.5d0-szm-sfw))/rsum

        parj(164)=(rqv*szw**2*(1d0-2d0*sfw)+rva*(2d0*sfi+szw**2-

     &  4d0+3d0*szm-szm**2))/(szw*rsum)

        sigv=1.5d0*ale-0.5d0+paru(1)**2/3d0+((2d0*rqq+sfi*rqv)/

     &  rsum)*sigv+(szw*sfw*rqv/rsum)*paru(1)*20d0/9d0

        sigs=ale*(2d0*log(xkl)+parj(161)*log(1d0-xkl)+parj(162)*xkl+

     &  parj(163)*log(((xkl-szm)**2+szw**2)/(szm**2+szw**2))+

     &  parj(164)*(atan((xkl-szm)/szw)-atan(-szm/szw)))

        sigh=ale*(2d0*log(xku/xkl)+parj(161)*log((1d0-xku)/

     &  (1d0-xkl))+parj(162)*(xku-xkl)+parj(163)*

     &  log(((xku-szm)**2+szw**2)/((xkl-szm)**2+szw**2))+

     &  parj(164)*(atan((xku-szm)/szw)-atan((xkl-szm)/szw)))

      ENDIF


C...Total cross-section and fraction of hard photon events.

      parj(160)=sigh/(paru(1)/paru(101)+sigv+sigs+sigh)

      parj(157)=rsum*(1d0+(paru(101)/paru(1))*(sigv+sigs+sigh))*rqcd

      parj(144)=parj(157)

      parj(148)=parj(144)*86.8d0/ecm**2

      xtot=parj(148)


      RETURN

      END


C*********************************************************************


C...PYRADK

C...Generates initial state photon radiation.


      SUBROUTINE pyradk(ECM,MK,PAK,THEK,PHIK,ALPK)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/


C...Function: cumulative hard photon spectrum in QFD case.

      fxk(xx)=2d0*log(xx)+parj(161)*log(1d0-xx)+parj(162)*xx+

     &parj(163)*log((xx-szm)**2+szw**2)+parj(164)*atan((xx-szm)/szw)


C...Determine whether radiative photon or not.

      mk=0

      pak=0d0

      IF(parj(160).LT.pyr(0)) RETURN

      mk=1


C...Photon energy range. Find photon momentum in QED case.

      xkl=parj(135)

      xku=min(parj(136),1d0-(2d0*parj(127)/ecm)**2)

      IF(mstj(102).LE.1) THEN

  100   xk=1d0/(1d0+(1d0/xkl-1d0)*((1d0/xku-1d0)/(1d0/xkl-1d0))**pyr(0))

        IF(1d0+(1d0-xk)**2.LT.2d0*pyr(0)) goto 100


C...Ditto in QFD case, by numerical inversion of integrated spectrum.

      ELSE

        szm=1d0-(parj(123)/ecm)**2

        szw=parj(123)*parj(124)/ecm**2

        fxkl=fxk(xkl)

        fxku=fxk(xku)

        fxkd=1d-4*(fxku-fxkl)

        fxkr=fxkl+pyr(0)*(fxku-fxkl)

        nxk=0

  110   nxk=nxk+1

        xk=0.5d0*(xkl+xku)

        fxkv=fxk(xk)

        IF(fxkv.GT.fxkr) THEN

          xku=xk

          fxku=fxkv

        ELSE

          xkl=xk

          fxkl=fxkv

        ENDIF

        IF(nxk.LT.15.AND.fxku-fxkl.GT.fxkd) goto 110

        xk=xkl+(xku-xkl)*(fxkr-fxkl)/(fxku-fxkl)

      ENDIF

      pak=0.5d0*ecm*xk


C...Photon polar and azimuthal angle.

      pme=2d0*(pymass(11)/ecm)**2

  120 cthm=pme*(2d0/pme)**pyr(0)

      IF(1d0-(xk**2*cthm*(1d0-0.5d0*cthm)+2d0*(1d0-xk)*pme/max(pme,

     &cthm*(1d0-0.5d0*cthm)))/(1d0+(1d0-xk)**2).LT.pyr(0)) goto 120

      cthe=1d0-cthm

      IF(pyr(0).GT.0.5d0) cthe=-cthe

      sthe=sqrt(max(0d0,(cthm-pme)*(2d0-cthm)))

      thek=pyangl(cthe,sthe)

      phik=paru(2)*pyr(0)


C...Rotation angle for hadronic system.

      sgn=1d0

      IF(0.5d0*(2d0-xk*(1d0-cthe))**2/((2d0-xk)**2+(xk*cthe)**2).GT.

     &pyr(0)) sgn=-1d0

      alpk=asin(sgn*sthe*(xk-sgn*(2d0*sqrt(1d0-xk)-2d0+xk)*cthe)/

     &(2d0-xk*(1d0-sgn*cthe)))


      RETURN

      END


C*********************************************************************


C...PYXKFL

C...Selects flavour for produced qqbar pair.


      SUBROUTINE pyxkfl(KFL,ECM,ECMC,KFLC)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pydat1/,/pydat2/


C...Calculate maximum weight in QED or QFD case.

      IF(mstj(102).LE.1) THEN

        rfmax=4d0/9d0

      ELSE

        poll=1d0-parj(131)*parj(132)

        sff=1d0/(16d0*paru(102)*(1d0-paru(102)))

        sfw=ecmc**4/((ecmc**2-parj(123)**2)**2+(parj(123)*parj(124))**2)

        sfi=sfw*(1d0-(parj(123)/ecmc)**2)

        ve=4d0*paru(102)-1d0

        hf1i=sfi*sff*(ve*poll+parj(132)-parj(131))

        hf1w=sfw*sff**2*((ve**2+1d0)*poll+2d0*ve*(parj(132)-parj(131)))

        rfmax=max(4d0/9d0*poll-4d0/3d0*(1d0-8d0*paru(102)/3d0)*hf1i+

     &  ((1d0-8d0*paru(102)/3d0)**2+1d0)*hf1w,1d0/9d0*poll+2d0/3d0*

     &  (-1d0+4d0*paru(102)/3d0)*hf1i+((-1d0+4d0*paru(102)/3d0)**2+

     &  1d0)*hf1w)

      ENDIF


C...Choose flavour. Gives charge and velocity.

      ntry=0

  100 ntry=ntry+1

      IF(ntry.GT.100) THEN

        CALL pyerrm(14,'(PYXKFL:) caught in an infinite loop')

        kflc=0

        RETURN

      ENDIF

      kflc=kfl

      IF(kfl.LE.0) kflc=1+int(mstj(104)*pyr(0))

      mstj(93)=1

      pmq=pymass(kflc)

      IF(ecm.LT.2d0*pmq+parj(127)) goto 100

      qf=kchg(kflc,1)/3d0

      vq=1d0

      IF(mod(mstj(103),2).EQ.1) vq=sqrt(max(0d0,1d0-(2d0*pmq/ecmc)**2))


C...Calculate weight in QED or QFD case.

      IF(mstj(102).LE.1) THEN

        rf=qf**2

        rfv=0.5d0*vq*(3d0-vq**2)*qf**2

      ELSE

        vf=sign(1d0,qf)-4d0*qf*paru(102)

        rf=qf**2*poll-2d0*qf*vf*hf1i+(vf**2+1d0)*hf1w

        rfv=0.5d0*vq*(3d0-vq**2)*(qf**2*poll-2d0*qf*vf*hf1i+vf**2*hf1w)+

     &  vq**3*hf1w

        IF(rfv.GT.0d0) parj(171)=min(1d0,vq**3*hf1w/rfv)

      ENDIF


C...Weighting or new event (radiative photon). Cross-section update.

      IF(kfl.LE.0.AND.rf.LT.pyr(0)*rfmax) goto 100

      parj(158)=parj(158)+1d0

      IF(ecmc.LT.2d0*pmq+parj(127).OR.rfv.LT.pyr(0)*rf) kflc=0

      IF(mstj(107).LE.0.AND.kflc.EQ.0) goto 100

      IF(kflc.NE.0) parj(159)=parj(159)+1d0

      parj(144)=parj(157)*parj(159)/parj(158)

      parj(148)=parj(144)*86.8d0/ecm**2


      RETURN

      END


C*********************************************************************


C...PYXJET

C...Selects number of jets in matrix element approach.


      SUBROUTINE pyxjet(ECM,NJET,CUT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local array and data.

      dimension zhut(5)

      DATA zhut/3.0922d0, 6.2291d0, 7.4782d0, 7.8440d0, 8.2560d0/


C...Trivial result for two-jets only, including parton shower.

      IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN

        cut=0d0


C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.

      ELSEIF(mstj(109).EQ.0.OR.mstj(109).EQ.2) THEN

        cf=4d0/3d0

        IF(mstj(109).EQ.2) cf=1d0

        IF(mstj(111).EQ.0) THEN

          q2=ecm**2

          q2r=ecm**2

        ELSEIF(mstu(111).EQ.0) THEN

          parj(169)=min(1d0,parj(129))

          q2=parj(169)*ecm**2

          parj(168)=min(1d0,max(parj(128),exp(-12d0*paru(1)/

     &    ((33d0-2d0*mstu(112))*paru(111)))))

          q2r=parj(168)*ecm**2

        ELSE

          parj(169)=min(1d0,max(parj(129),(2d0*paru(112)/ecm)**2))

          q2=parj(169)*ecm**2

          parj(168)=min(1d0,max(parj(128),paru(112)/ecm,

     &    (2d0*paru(112)/ecm)**2))

          q2r=parj(168)*ecm**2

        ENDIF


C...alpha_strong for R and R itself.

        alspi=(3d0/4d0)*cf*pyalps(q2r)/paru(1)

        IF(iabs(mstj(101)).EQ.1) THEN

          rqcd=1d0+alspi

        ELSEIF(mstj(109).EQ.0) THEN

          rqcd=1d0+alspi+(1.986d0-0.115d0*mstu(118))*alspi**2

          IF(mstj(111).EQ.1) rqcd=max(1d0,rqcd+

     &    (33d0-2d0*mstu(112))/12d0*log(parj(168))*alspi**2)

        ELSE

          rqcd=1d0+alspi-(3d0/32d0+0.519d0*mstu(118))*(4d0*alspi/3d0)**2

        ENDIF


C...alpha_strong for jet rate. Initial value for y cut.

        alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)

        cut=max(0.001d0,parj(125),(parj(126)/ecm)**2)

        IF(iabs(mstj(101)).LE.1.OR.(mstj(109).EQ.0.AND.mstj(111).EQ.0))

     &  cut=max(cut,exp(-sqrt(0.75d0/alspi))/2d0)

        IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))


C...Parametrization of first order three-jet cross-section.

  100   IF(mstj(101).EQ.0.OR.cut.GE.0.25d0) THEN

          parj(152)=0d0

        ELSE

          parj(152)=(2d0*alspi/3d0)*((3d0-6d0*cut+2d0*log(cut))*

     &    log(cut/(1d0-2d0*cut))+(2.5d0+1.5d0*cut-6.571d0)*

     &    (1d0-3d0*cut)+5.833d0*(1d0-3d0*cut)**2-3.894d0*

     &    (1d0-3d0*cut)**3+1.342d0*(1d0-3d0*cut)**4)/rqcd

          IF(mstj(109).EQ.2.AND.(mstj(101).EQ.2.OR.mstj(101).LE.-2))

     &    parj(152)=0d0

        ENDIF


C...Parametrization of second order three-jet cross-section.

        IF(iabs(mstj(101)).LE.1.OR.mstj(101).EQ.3.OR.mstj(109).EQ.2.OR.

     &  cut.GE.0.25d0) THEN

          parj(153)=0d0

        ELSEIF(mstj(110).LE.1) THEN

          ct=log(1d0/cut-2d0)

          parj(153)=alspi**2*ct**2*(2.419d0+0.5989d0*ct+0.6782d0*ct**2-

     &    0.2661d0*ct**3+0.01159d0*ct**4)/rqcd


C...Interpolation in second/first order ratio for Zhu parametrization.

        ELSEIF(mstj(110).EQ.2) THEN

          iza=0

          DO 110 iy=1,5

            IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy

  110     CONTINUE

          IF(iza.NE.0) THEN

            zhurat=zhut(iza)

          ELSE

            iz=100d0*cut

            zhurat=zhut(iz)+(100d0*cut-iz)*(zhut(iz+1)-zhut(iz))

          ENDIF

          parj(153)=alspi*parj(152)*zhurat

        ENDIF


C...Shift in second order three-jet cross-section with optimized Q^2.

        IF(mstj(111).EQ.1.AND.iabs(mstj(101)).GE.2.AND.mstj(101).NE.3

     &  .AND.cut.LT.0.25d0) parj(153)=parj(153)+

     &  (33d0-2d0*mstu(112))/12d0*log(parj(169))*alspi*parj(152)


C...Parametrization of second order four-jet cross-section.

        IF(iabs(mstj(101)).LE.1.OR.cut.GE.0.125d0) THEN

          parj(154)=0d0

        ELSE

          ct=log(1d0/cut-5d0)

          IF(cut.LE.0.018d0) THEN

            xqqgg=6.349d0-4.330d0*ct+0.8304d0*ct**2

            IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(3.035d0-2.091d0*ct+

     &      0.4059d0*ct**2)

            xqqqq=1.25d0*(-0.1080d0+0.01486d0*ct+0.009364d0*ct**2)

            IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq

          ELSE

            xqqgg=-0.09773d0+0.2959d0*ct-0.2764d0*ct**2+0.08832d0*ct**3

            IF(mstj(109).EQ.2) xqqgg=(4d0/3d0)**2*(-0.04079d0+

     &      0.1340d0*ct-0.1326d0*ct**2+0.04365d0*ct**3)

            xqqqq=1.25d0*(0.003661d0-0.004888d0*ct-0.001081d0*ct**2+

     &      0.002093d0*ct**3)

            IF(mstj(109).EQ.2) xqqqq=8d0*xqqqq

          ENDIF

          parj(154)=alspi**2*ct**2*(xqqgg+xqqqq)/rqcd

          parj(155)=xqqqq/(xqqgg+xqqqq)

        ENDIF


C...If negative three-jet rate, change y' optimization parameter.

        IF(mstj(111).EQ.1.AND.parj(152)+parj(153).LT.0d0.AND.

     &  parj(169).LT.0.99d0) THEN

          parj(169)=min(1d0,1.2d0*parj(169))

          q2=parj(169)*ecm**2

          alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)

          goto 100

        ENDIF


C...If too high cross-section, use harder cuts, or fail.

        IF(parj(152)+parj(153)+parj(154).GE.1) THEN

          IF(mstj(110).EQ.2.AND.cut.GT.0.0499d0.AND.mstj(111).EQ.1.AND.

     &    parj(169).LT.0.99d0) THEN

            parj(169)=min(1d0,1.2d0*parj(169))

            q2=parj(169)*ecm**2

            alspi=(3d0/4d0)*cf*pyalps(q2)/paru(1)

            goto 100

          ELSEIF(mstj(110).EQ.2.AND.cut.GT.0.0499d0) THEN

            CALL pyerrm(26,

     &      '(PYXJET:) no allowed y cut value for Zhu parametrization')

          ENDIF

          cut=0.26d0*(4d0*cut)**(parj(152)+parj(153)+

     &    parj(154))**(-1d0/3d0)

          IF(mstj(110).EQ.2) cut=max(0.01d0,min(0.05d0,cut))

          goto 100

        ENDIF


C...Scalar gluon (first order only).

      ELSE

        alspi=pyalps(ecm**2)/paru(1)

        cut=max(0.001d0,parj(125),(parj(126)/ecm)**2,exp(-3d0/alspi))

        parj(152)=0d0

        IF(cut.LT.0.25d0) parj(152)=(alspi/3d0)*((1d0-2d0*cut)*

     &  log((1d0-2d0*cut)/cut)+0.5d0*(9d0*cut**2-1d0))

        parj(153)=0d0

        parj(154)=0d0

      ENDIF


C...Select number of jets.

      parj(150)=cut

      IF(mstj(101).EQ.0.OR.mstj(101).EQ.5) THEN

        njet=2

      ELSEIF(mstj(101).LE.0) THEN

        njet=min(4,2-mstj(101))

      ELSE

        rnj=pyr(0)

        njet=2

        IF(parj(152)+parj(153)+parj(154).GT.rnj) njet=3

        IF(parj(154).GT.rnj) njet=4

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYX3JT

C...Selects the kinematical variables of three-jet events.


      SUBROUTINE pyx3jt(NJET,CUT,KFL,ECM,X1,X2)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local array.

      dimension zhup(5,12)


C...Coefficients of Zhu second order parametrization.

      DATA ((zhup(ic1,ic2),ic2=1,12),ic1=1,5)/

     &18.29d0,  89.56d0,  4.541d0,  -52.09d0, -109.8d0,  24.90d0,

     &11.63d0,  3.683d0,  17.50d0,0.002440d0, -1.362d0,-0.3537d0,

     &11.42d0,  6.299d0, -22.55d0,  -8.915d0,  59.25d0, -5.855d0,

     &-32.85d0, -1.054d0, -16.90d0,0.006489d0,-0.8156d0,0.01095d0,

     &7.847d0, -3.964d0, -35.83d0,   1.178d0,  29.39d0, 0.2806d0,

     &47.82d0, -12.36d0, -56.72d0, 0.04054d0,-0.4365d0, 0.6062d0,

     &5.441d0, -56.89d0, -50.27d0,   15.13d0,  114.3d0, -18.19d0,

     &97.05d0, -1.890d0, -139.9d0, 0.08153d0,-0.4984d0, 0.9439d0,

     &-17.65d0,  51.44d0, -58.32d0,   70.95d0, -255.7d0, -78.99d0,

     &476.9d0,  29.65d0, -239.3d0,  0.4745d0, -1.174d0,  6.081d0/


C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).

      dilog(x)=x+x**2/4d0+x**3/9d0+x**4/16d0+x**5/25d0+x**6/36d0+

     &x**7/49d0


C...Event type. Mass effect factors and other common constants.

      mstj(120)=2

      mstj(121)=0

      pmq=pymass(kfl)

      qme=(2d0*pmq/ecm)**2

      IF(mstj(109).NE.1) THEN

        cutl=log(cut)

        cutd=log(1d0/cut-2d0)

        IF(mstj(109).EQ.0) THEN

          cf=4d0/3d0

          cn=3d0

          tr=2d0

          wtmx=min(20d0,37d0-6d0*cutd)

          IF(mstj(110).EQ.2) wtmx=2d0*(7.5d0+80d0*cut)

        ELSE

          cf=1d0

          cn=0d0

          tr=12d0

          wtmx=0d0

        ENDIF


C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.

        als2pi=paru(118)/paru(2)

        wtopt=0d0

        IF(mstj(111).EQ.1) wtopt=(33d0-2d0*mstu(112))/6d0*

     &  log(parj(169))*als2pi

        wtmax=max(0d0,1d0+wtopt+als2pi*wtmx)


C...Choose three-jet events in allowed region.

  100   njet=3

  110   y13l=cutl+cutd*pyr(0)

        y23l=cutl+cutd*pyr(0)

        y13=exp(y13l)

        y23=exp(y23l)

        y12=1d0-y13-y23

        IF(y12.LE.cut) goto 110

        IF(y13**2+y23**2+2d0*y12.LE.2d0*pyr(0)) goto 110


C...Second order corrections.

        IF(mstj(101).EQ.2.AND.mstj(110).LE.1) THEN

          y12l=log(y12)

          y13m=log(1d0-y13)

          y23m=log(1d0-y23)

          y12m=log(1d0-y12)

          IF(y13.LE.0.5d0) y13i=dilog(y13)

          IF(y13.GE.0.5d0) y13i=1.644934d0-y13l*y13m-dilog(1d0-y13)

          IF(y23.LE.0.5d0) y23i=dilog(y23)

          IF(y23.GE.0.5d0) y23i=1.644934d0-y23l*y23m-dilog(1d0-y23)

          IF(y12.LE.0.5d0) y12i=dilog(y12)

          IF(y12.GE.0.5d0) y12i=1.644934d0-y12l*y12m-dilog(1d0-y12)

          wt1=(y13**2+y23**2+2d0*y12)/(y13*y23)

          wt2=cf*(-2d0*(cutl-y12l)**2-3d0*cutl-1d0+3.289868d0+

     &    2d0*(2d0*cutl-y12l)*cut/y12)+

     &    cn*((cutl-y12l)**2-(cutl-y13l)**2-(cutl-y23l)**2-

     &    11d0*cutl/6d0+67d0/18d0+1.644934d0-(2d0*cutl-y12l)*cut/y12+

     &    (2d0*cutl-y13l)*cut/y13+(2d0*cutl-y23l)*cut/y23)+

     &    tr*(2d0*cutl/3d0-10d0/9d0)+

     &    cf*(y12/(y12+y13)+y12/(y12+y23)+(y12+y23)/y13+(y12+y13)/y23+

     &    y13l*(4d0*y12**2+2d0*y12*y13+4d0*y12*y23+y13*y23)/

     &    (y12+y23)**2+y23l*(4d0*y12**2+2d0*y12*y23+4d0*y12*y13+

     &    y13*y23)/(y12+y13)**2)/wt1+

     &    cn*(y13l*y13/(y12+y23)+y23l*y23/(y12+y13))/wt1+(cn-2d0*cf)*

     &    ((y12**2+(y12+y13)**2)*(y12l*y23l-y12l*y12m-y23l*

     &    y23m+1.644934d0-y12i-y23i)/(y13*y23)+(y12**2+(y12+y23)**2)*

     &    (y12l*y13l-y12l*y12m-y13l*y13m+1.644934d0-y12i-y13i)/

     &    (y13*y23)+(y13**2+y23**2)/(y13*y23*(y13+y23))-

     &    2d0*y12l*y12**2/(y13+y23)**2-4d0*y12l*y12/(y13+y23))/wt1-

     &    cn*(y13l*y23l-y13l*y13m-y23l*y23m+1.644934d0-y13i-y23i)

          IF(1d0+wtopt+als2pi*wt2.LE.0d0) mstj(121)=1

          IF(1d0+wtopt+als2pi*wt2.LE.wtmax*pyr(0)) goto 110

          parj(156)=(wtopt+als2pi*wt2)/(1d0+wtopt+als2pi*wt2)


        ELSEIF(mstj(101).EQ.2.AND.mstj(110).EQ.2) THEN

C...Second order corrections; Zhu parametrization of ERT.

          zx=(y23-y13)**2

          zy=1d0-y12

          iza=0

          DO 120 iy=1,5

            IF(abs(cut-0.01d0*iy).LT.0.0001d0) iza=iy

  120     CONTINUE

          IF(iza.NE.0) THEN

            iz=iza

            wt2=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+

     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+

     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+

     &      zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy

          ELSE

            iz=100d0*cut

            wtl=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+

     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+

     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+

     &      zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy

            iz=iz+1

            wtu=zhup(iz,1)+zhup(iz,2)*zx+zhup(iz,3)*zx**2+(zhup(iz,4)+

     &      zhup(iz,5)*zx)*zy+(zhup(iz,6)+zhup(iz,7)*zx)*zy**2+

     &      (zhup(iz,8)+zhup(iz,9)*zx)*zy**3+zhup(iz,10)/(zx-zy**2)+

     &      zhup(iz,11)/(1d0-zy)+zhup(iz,12)/zy

            wt2=wtl+(wtu-wtl)*(100d0*cut+1d0-iz)

          ENDIF

          IF(1d0+wtopt+2d0*als2pi*wt2.LE.0d0) mstj(121)=1

          IF(1d0+wtopt+2d0*als2pi*wt2.LE.wtmax*pyr(0)) goto 110

          parj(156)=(wtopt+2d0*als2pi*wt2)/(1d0+wtopt+2d0*als2pi*wt2)

        ENDIF


C...Impose mass cuts (gives two jets). For fixed jet number new try.

        x1=1d0-y23

        x2=1d0-y13

        x3=1d0-y12

        IF(4d0*y23*y13*y12/x3**2.LE.qme) njet=2

        IF(mod(mstj(103),4).GE.2.AND.iabs(mstj(101)).LE.1.AND.qme*x3+

     &  0.5d0*qme**2+(0.5d0*qme+0.25d0*qme**2)*((1d0-x2)/(1d0-x1)+

     &  (1d0-x1)/(1d0-x2)).GT.(x1**2+x2**2)*pyr(0)) njet=2

        IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 100


C...Scalar gluon model (first order only, no mass effects).

      ELSE

  130   njet=3

  140   x3=sqrt(4d0*cut**2+pyr(0)*((1d0-cut)**2-4d0*cut**2))

        IF(log((x3-cut)/cut).LE.pyr(0)*log((1d0-2d0*cut)/cut)) goto 140

        yd=sign(2d0*cut*((x3-cut)/cut)**pyr(0)-x3,pyr(0)-0.5d0)

        x1=1d0-0.5d0*(x3+yd)

        x2=1d0-0.5d0*(x3-yd)

        IF(4d0*(1d0-x1)*(1d0-x2)*(1d0-x3)/x3**2.LE.qme) njet=2

        IF(mstj(102).GE.2) THEN

          IF(x3**2-2d0*(1d0+x3)*(1d0-x1)*(1d0-x2)*parj(171).LT.

     &    x3**2*pyr(0)) njet=2

        ENDIF

        IF(mstj(101).EQ.-1.AND.njet.EQ.2) goto 130

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYX4JT

C...Selects the kinematical variables of four-jet events.


      SUBROUTINE pyx4jt(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local arrays.

      dimension wta(4),wtb(4),wtc(4),wtd(4),wte(4)


C...Common constants. Colour factors for QCD and Abelian gluon theory.

      pmq=pymass(kfl)

      qme=(2d0*pmq/ecm)**2

      ct=log(1d0/cut-5d0)

      IF(mstj(109).EQ.0) THEN

        cf=4d0/3d0

        cn=3d0

        tr=2.5d0

      ELSE

        cf=1d0

        cn=0d0

        tr=15d0

      ENDIF


C...Choice of process (qqbargg or qqbarqqbar).

  100 njet=4

      it=1

      IF(parj(155).GT.pyr(0)) it=2

      IF(mstj(101).LE.-3) it=-mstj(101)-2

      IF(it.EQ.1) wtmx=0.7d0/cut**2

      IF(it.EQ.1.AND.mstj(109).EQ.2) wtmx=0.6d0/cut**2

      IF(it.EQ.2) wtmx=0.1125d0*cf*tr/cut**2

      id=1


C...Sample the five kinematical variables (for qqgg preweighted in y34).

  110 y134=3d0*cut+(1d0-6d0*cut)*pyr(0)

      y234=3d0*cut+(1d0-6d0*cut)*pyr(0)

      IF(it.EQ.1) y34=(1d0-5d0*cut)*exp(-ct*pyr(0))

      IF(it.EQ.2) y34=cut+(1d0-6d0*cut)*pyr(0)

      IF(y34.LE.y134+y234-1d0.OR.y34.GE.y134*y234) goto 110

      vt=pyr(0)

      cp=cos(paru(1)*pyr(0))

      y14=(y134-y34)*vt

      y13=y134-y14-y34

      vb=y34*(1d0-y134-y234+y34)/((y134-y34)*(y234-y34))

      y24=0.5d0*(y234-y34)*(1d0-4d0*sqrt(max(0d0,vt*(1d0-vt)*

     &vb*(1d0-vb)))*cp-(1d0-2d0*vt)*(1d0-2d0*vb))

      y23=y234-y34-y24

      y12=1d0-y134-y23-y24

      IF(min(y12,y13,y14,y23,y24).LE.cut) goto 110

      y123=y12+y13+y23

      y124=y12+y14+y24


C...Calculate matrix elements for qqgg or qqqq process.

      ic=0

      wttot=0d0

  120 ic=ic+1

      IF(it.EQ.1) THEN

        wta(ic)=(y12*y34**2-y13*y24*y34+y14*y23*y34+3d0*y12*y23*y34+

     &  3d0*y12*y14*y34+4d0*y12**2*y34-y13*y23*y24+2d0*y12*y23*y24-

     &  y13*y14*y24-2d0*y12*y13*y24+2d0*y12**2*y24+y14*y23**2+2d0*y12*

     &  y23**2+y14**2*y23+4d0*y12*y14*y23+4d0*y12**2*y23+2d0*y12*y14**2+

     &  2d0*y12*y13*y14+4d0*y12**2*y14+2d0*y12**2*y13+2d0*y12**3)/

     &  (2d0*y13*y134*y234*y24)+(y24*y34+y12*y34+y13*y24-

     &  y14*y23+y12*y13)/(y13*y134**2)+2d0*y23*(1d0-y13)/

     &  (y13*y134*y24)+y34/(2d0*y13*y24)

        wtb(ic)=(y12*y24*y34+y12*y14*y34-y13*y24**2+y13*y14*y24+2d0*y12*

     &  y14*y24)/(y13*y134*y23*y14)+y12*(1d0+y34)*y124/(y134*y234*y14*

     &  y24)-(2d0*y13*y24+y14**2+y13*y23+2d0*y12*y13)/(y13*y134*y14)+

     &  y12*y123*y124/(2d0*y13*y14*y23*y24)

        wtc(ic)=-(5d0*y12*y34**2+2d0*y12*y24*y34+2d0*y12*y23*y34+

     &  2d0*y12*y14*y34+2d0*y12*y13*y34+4d0*y12**2*y34-y13*y24**2+

     &  y14*y23*y24+y13*y23*y24+y13*y14*y24-y12*y14*y24-y13**2*y24-

     &  3d0*y12*y13*y24-y14*y23**2-y14**2*y23+y13*y14*y23-

     &  3d0*y12*y14*y23-y12*y13*y23)/(4d0*y134*y234*y34**2)+

     &  (3d0*y12*y34**2-3d0*y13*y24*y34+3d0*y12*y24*y34+

     &  3d0*y14*y23*y34-y13*y24**2-y12*y23*y34+6d0*y12*y14*y34+

     &  2d0*y12*y13*y34-2d0*y12**2*y34+y14*y23*y24-3d0*y13*y23*y24-

     &  2d0*y13*y14*y24+4d0*y12*y14*y24+2d0*y12*y13*y24+

     &  3d0*y14*y23**2+2d0*y14**2*y23+2d0*y14**2*y12+

     &  2d0*y12**2*y14+6d0*y12*y14*y23-2d0*y12*y13**2-

     &  2d0*y12**2*y13)/(4d0*y13*y134*y234*y34)

        wtc(ic)=wtc(ic)+(2d0*y12*y34**2-2d0*y13*y24*y34+y12*y24*y34+

     &  4d0*y13*y23*y34+4d0*y12*y14*y34+2d0*y12*y13*y34+2d0*y12**2*y34-

     &  y13*y24**2+3d0*y14*y23*y24+4d0*y13*y23*y24-2d0*y13*y14*y24+

     &  4d0*y12*y14*y24+2d0*y12*y13*y24+2d0*y14*y23**2+4d0*y13*y23**2+

     &  2d0*y13*y14*y23+2d0*y12*y14*y23+4d0*y12*y13*y23+2d0*y12*y14**2+

     &  4d0*y12**2*y13+4d0*y12*y13*y14+2d0*y12**2*y14)/

     &  (4d0*y13*y134*y24*y34)-(y12*y34**2-2d0*y14*y24*y34-

     &  2d0*y13*y24*y34-y14*y23*y34+y13*y23*y34+y12*y14*y34+

     &  2d0*y12*y13*y34-2d0*y14**2*y24-4d0*y13*y14*y24-

     &  4d0*y13**2*y24-y14**2*y23-y13**2*y23+y12*y13*y14-

     &  y12*y13**2)/(2d0*y13*y34*y134**2)+(y12*y34**2-

     &  4d0*y14*y24*y34-2d0*y13*y24*y34-2d0*y14*y23*y34-

     &  4d0*y13*y23*y34-4d0*y12*y14*y34-4d0*y12*y13*y34-

     &  2d0*y13*y14*y24+2d0*y13**2*y24+2d0*y14**2*y23-

     &  2d0*y13*y14*y23-y12*y14**2-6d0*y12*y13*y14-

     &  y12*y13**2)/(4d0*y34**2*y134**2)

        wttot=wttot+y34*cf*(cf*wta(ic)+(cf-0.5d0*cn)*wtb(ic)+

     &  cn*wtc(ic))/8d0

      ELSE

        wtd(ic)=(y13*y23*y34+y12*y23*y34-y12**2*y34+y13*y23*y24+2d0*y12*

     &  y23*y24-y14*y23**2+y12*y13*y24+y12*y14*y23+y12*y13*y14)/(y13**2*

     &  y123**2)-(y12*y34**2-y13*y24*y34+y12*y24*y34-y14*y23*y34-y12*

     &  y23*y34-y13*y24**2+y14*y23*y24-y13*y23*y24-y13**2*y24+y14*

     &  y23**2)/(y13**2*y123*y134)+(y13*y14*y12+y34*y14*y12-y34**2*y12+

     &  y13*y14*y24+2d0*y34*y14*y24-y23*y14**2+y34*y13*y24+y34*y23*y14+

     &  y34*y13*y23)/(y13**2*y134**2)-(y34*y12**2-y13*y24*y12+y34*y24*

     &  y12-y23*y14*y12-y34*y14*y12-y13*y24**2+y23*y14*y24-y13*y14*y24-

     &  y13**2*y24+y23*y14**2)/(y13**2*y134*y123)

        wte(ic)=(y12*y34*(y23-y24+y14+y13)+y13*y24**2-y14*y23*y24+y13*

     &  y23*y24+y13*y14*y24+y13**2*y24-y14*y23*(y14+y23+y13))/(y13*y23*

     &  y123*y134)-y12*(y12*y34-y23*y24-y13*y24-y14*y23-y14*y13)/(y13*

     &  y23*y123**2)-(y14+y13)*(y24+y23)*y34/(y13*y23*y134*y234)+

     &  (y12*y34*(y14-y24+y23+y13)+y13*y24**2-y23*y14*y24+y13*y14*y24+

     &  y13*y23*y24+y13**2*y24-y23*y14*(y14+y23+y13))/(y13*y14*y134*

     &  y123)-y34*(y34*y12-y14*y24-y13*y24-y23*y14-y23*y13)/(y13*y14*

     &  y134**2)-(y23+y13)*(y24+y14)*y12/(y13*y14*y123*y124)

        wttot=wttot+cf*(tr*wtd(ic)+(cf-0.5d0*cn)*wte(ic))/16d0

      ENDIF


C...Permutations of momenta in matrix element. Weighting.

  130 IF(ic.EQ.1.OR.ic.EQ.3.OR.id.EQ.2.OR.id.EQ.3) THEN

        ysav=y13

        y13=y14

        y14=ysav

        ysav=y23

        y23=y24

        y24=ysav

        ysav=y123

        y123=y124

        y124=ysav

      ENDIF

      IF(ic.EQ.2.OR.ic.EQ.4.OR.id.EQ.3.OR.id.EQ.4) THEN

        ysav=y13

        y13=y23

        y23=ysav

        ysav=y14

        y14=y24

        y24=ysav

        ysav=y134

        y134=y234

        y234=ysav

      ENDIF

      IF(ic.LE.3) goto 120

      IF(id.EQ.1.AND.wttot.LT.pyr(0)*wtmx) goto 110

      ic=5


C...qqgg events: string configuration and event type.

      IF(it.EQ.1) THEN

        IF(mstj(109).EQ.0.AND.id.EQ.1) THEN

          parj(156)=y34*(2d0*(wta(1)+wta(2)+wta(3)+wta(4))+4d0*(wtc(1)+

     &    wtc(2)+wtc(3)+wtc(4)))/(9d0*wttot)

          IF(wta(2)+wta(4)+2d0*(wtc(2)+wtc(4)).GT.pyr(0)*(wta(1)+wta(2)+

     &    wta(3)+wta(4)+2d0*(wtc(1)+wtc(2)+wtc(3)+wtc(4)))) id=2

          IF(id.EQ.2) goto 130

        ELSEIF(mstj(109).EQ.2.AND.id.EQ.1) THEN

          parj(156)=y34*(wta(1)+wta(2)+wta(3)+wta(4))/(8d0*wttot)

          IF(wta(2)+wta(4).GT.pyr(0)*(wta(1)+wta(2)+wta(3)+wta(4))) id=2

          IF(id.EQ.2) goto 130

        ENDIF

        mstj(120)=3

        IF(mstj(109).EQ.0.AND.0.5d0*y34*(wtc(1)+wtc(2)+wtc(3)+

     &  wtc(4)).GT.pyr(0)*wttot) mstj(120)=4

        kfln=21


C...Mass cuts. Kinematical variables out.

        IF(y12.LE.cut+qme) njet=2

        IF(njet.EQ.2) goto 150

        q12=0.5d0*(1d0-sqrt(1d0-qme/y12))

        x1=1d0-(1d0-q12)*y234-q12*y134

        x4=1d0-(1d0-q12)*y134-q12*y234

        x2=1d0-y124

        x12=(1d0-q12)*y13+q12*y23

        x14=y12-0.5d0*qme

        IF(y134*y234/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2


C...qqbarqqbar events: string configuration, choose new flavour.

      ELSE

        IF(id.EQ.1) THEN

          wtr=pyr(0)*(wtd(1)+wtd(2)+wtd(3)+wtd(4))

          IF(wtr.LT.wtd(2)+wtd(3)+wtd(4)) id=2

          IF(wtr.LT.wtd(3)+wtd(4)) id=3

          IF(wtr.LT.wtd(4)) id=4

          IF(id.GE.2) goto 130

        ENDIF

        mstj(120)=5

        parj(156)=cf*tr*(wtd(1)+wtd(2)+wtd(3)+wtd(4))/(16d0*wttot)

  140   kfln=1+int(5d0*pyr(0))

        IF(kfln.NE.kfl.AND.0.2d0*parj(156).LE.pyr(0)) goto 140

        IF(kfln.EQ.kfl.AND.1d0-0.8d0*parj(156).LE.pyr(0)) goto 140

        IF(kfln.GT.mstj(104)) njet=2

        pmqn=pymass(kfln)

        qmen=(2d0*pmqn/ecm)**2


C...Mass cuts. Kinematical variables out.

        IF(y24.LE.cut+qme.OR.y13.LE.1.1d0*qmen) njet=2

        IF(njet.EQ.2) goto 150

        q24=0.5d0*(1d0-sqrt(1d0-qme/y24))

        q13=0.5d0*(1d0-sqrt(1d0-qmen/y13))

        x1=1d0-(1d0-q24)*y123-q24*y134

        x4=1d0-(1d0-q24)*y134-q24*y123

        x2=1d0-(1d0-q13)*y234-q13*y124

        x12=(1d0-q24)*((1d0-q13)*y14+q13*y34)+q24*((1d0-q13)*y12+

     &  q13*y23)

        x14=y24-0.5d0*qme

        x34=(1d0-q24)*((1d0-q13)*y23+q13*y12)+q24*((1d0-q13)*y34+

     &  q13*y14)

        IF(pmq**2+pmqn**2+min(x12,x34)*ecm**2.LE.

     &  (parj(127)+pmq+pmqn)**2) njet=2

        IF(y123*y134/((1d0-x1)*(1d0-x4)).LE.pyr(0)) njet=2

      ENDIF

  150 IF(mstj(101).LE.-2.AND.njet.EQ.2) goto 100


      RETURN

      END


C*********************************************************************


C...PYXDIF

C...Gives the angular orientation of events.


      SUBROUTINE pyxdif(NC,NJET,KFL,ECM,CHI,THE,PHI)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Charge. Factors depending on polarization for QED case.

      qf=kchg(kfl,1)/3d0

      poll=1d0-parj(131)*parj(132)

      pold=parj(132)-parj(131)

      IF(mstj(102).LE.1.OR.mstj(109).EQ.1) THEN

        hf1=poll

        hf2=0d0

        hf3=parj(133)**2

        hf4=0d0


C...Factors depending on flavour, energy and polarization for QFD case.

      ELSE

        sff=1d0/(16d0*paru(102)*(1d0-paru(102)))

        sfw=ecm**4/((ecm**2-parj(123)**2)**2+(parj(123)*parj(124))**2)

        sfi=sfw*(1d0-(parj(123)/ecm)**2)

        ae=-1d0

        ve=4d0*paru(102)-1d0

        af=sign(1d0,qf)

        vf=af-4d0*qf*paru(102)

        hf1=qf**2*poll-2d0*qf*vf*sfi*sff*(ve*poll-ae*pold)+

     &  (vf**2+af**2)*sfw*sff**2*((ve**2+ae**2)*poll-2d0*ve*ae*pold)

        hf2=-2d0*qf*af*sfi*sff*(ae*poll-ve*pold)+2d0*vf*af*sfw*sff**2*

     &  (2d0*ve*ae*poll-(ve**2+ae**2)*pold)

        hf3=parj(133)**2*(qf**2-2d0*qf*vf*sfi*sff*ve+(vf**2+af**2)*

     &  sfw*sff**2*(ve**2-ae**2))

        hf4=-parj(133)**2*2d0*qf*vf*sfw*(parj(123)*parj(124)/ecm**2)*

     &  sff*ae

      ENDIF


C...Mass factor. Differential cross-sections for two-jet events.

      sq2=sqrt(2d0)

      qme=0d0

      IF(mstj(103).GE.4.AND.iabs(mstj(101)).LE.1.AND.mstj(102).LE.1.AND.

     &mstj(109).NE.1) qme=(2d0*pymass(kfl)/ecm)**2

      IF(njet.EQ.2) THEN

        sigu=4d0*sqrt(1d0-qme)

        sigl=2d0*qme*sqrt(1d0-qme)

        sigt=0d0

        sigi=0d0

        siga=0d0

        sigp=4d0


C...Kinematical variables. Reduce four-jet event to three-jet one.

      ELSE

        IF(njet.EQ.3) THEN

          x1=2d0*p(nc+1,4)/ecm

          x2=2d0*p(nc+3,4)/ecm

        ELSE

          ecmr=p(nc+1,4)+p(nc+4,4)+sqrt((p(nc+2,1)+p(nc+3,1))**2+

     &    (p(nc+2,2)+p(nc+3,2))**2+(p(nc+2,3)+p(nc+3,3))**2)

          x1=2d0*p(nc+1,4)/ecmr

          x2=2d0*p(nc+4,4)/ecmr

        ENDIF


C...Differential cross-sections for three-jet (or reduced four-jet).

        xq=(1d0-x1)/(1d0-x2)

        ct12=(x1*x2-2d0*x1-2d0*x2+2d0+qme)/sqrt((x1**2-qme)*(x2**2-qme))

        st12=sqrt(1d0-ct12**2)

        IF(mstj(109).NE.1) THEN

          sigu=2d0*x1**2+x2**2*(1d0+ct12**2)-qme*(3d0+ct12**2-x1-x2)-

     &    qme*x1/xq+0.5d0*qme*((x2**2-qme)*st12**2-2d0*x2)*xq

          sigl=(x2*st12)**2-qme*(3d0-ct12**2-2.5d0*(x1+x2)+x1*x2+qme)+

     &    0.5d0*qme*(x1**2-x1-qme)/xq+0.5d0*qme*((x2**2-qme)*ct12**2-

     &    x2)*xq

          sigt=0.5d0*(x2**2-qme-0.5d0*qme*(x2**2-qme)/xq)*st12**2

          sigi=((1d0-0.5d0*qme*xq)*(x2**2-qme)*st12*ct12+

     &    qme*(1d0-x1-x2+0.5d0*x1*x2+0.5d0*qme)*st12/ct12)/sq2

          siga=x2**2*st12/sq2

          sigp=2d0*(x1**2-x2**2*ct12)


C...Differential cross-sect for scalar gluons (no mass effects).

        ELSE

          x3=2d0-x1-x2

          xt=x2*st12

          ct13=sqrt(max(0d0,1d0-(xt/x3)**2))

          sigu=(1d0-parj(171))*(x3**2-0.5d0*xt**2)+

     &    parj(171)*(x3**2-0.5d0*xt**2-4d0*(1d0-x1)*(1d0-x2)**2/x1)

          sigl=(1d0-parj(171))*0.5d0*xt**2+

     &    parj(171)*0.5d0*(1d0-x1)**2*xt**2

          sigt=(1d0-parj(171))*0.25d0*xt**2+

     &    parj(171)*0.25d0*xt**2*(1d0-2d0*x1)

          sigi=-(0.5d0/sq2)*((1d0-parj(171))*xt*x3*ct13+

     &    parj(171)*xt*((1d0-2d0*x1)*x3*ct13-x1*(x1-x2)))

          siga=(0.25d0/sq2)*xt*(2d0*(1d0-x1)-x1*x3)

          sigp=x3**2-2d0*(1d0-x1)*(1d0-x2)/x1

        ENDIF

      ENDIF


C...Upper bounds for differential cross-section.

      hf1a=abs(hf1)

      hf2a=abs(hf2)

      hf3a=abs(hf3)

      hf4a=abs(hf4)

      sigmax=(2d0*hf1a+hf3a+hf4a)*abs(sigu)+2d0*(hf1a+hf3a+hf4a)*

     &abs(sigl)+2d0*(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigt)+2d0*sq2*

     &(hf1a+2d0*hf3a+2d0*hf4a)*abs(sigi)+4d0*sq2*hf2a*abs(siga)+

     &2d0*hf2a*abs(sigp)


C...Generate angular orientation according to differential cross-sect.

  100 chi=paru(2)*pyr(0)

      cthe=2d0*pyr(0)-1d0

      phi=paru(2)*pyr(0)

      cchi=cos(chi)

      schi=sin(chi)

      c2chi=cos(2d0*chi)

      s2chi=sin(2d0*chi)

      the=acos(cthe)

      sthe=sin(the)

      c2phi=cos(2d0*(phi-parj(134)))

      s2phi=sin(2d0*(phi-parj(134)))

      sig=((1d0+cthe**2)*hf1+sthe**2*(c2phi*hf3-s2phi*hf4))*sigu+

     &2d0*(sthe**2*hf1-sthe**2*(c2phi*hf3-s2phi*hf4))*sigl+

     &2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*c2chi*c2phi-2d0*cthe*s2chi*

     &s2phi)*hf3-((1d0+cthe**2)*c2chi*s2phi+2d0*cthe*s2chi*c2phi)*hf4)*

     &sigt-2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*(cthe*cchi*c2phi-

     &schi*s2phi)*hf3+2d0*sthe*(cthe*cchi*s2phi+schi*c2phi)*hf4)*sigi+

     &4d0*sq2*sthe*cchi*hf2*siga+2d0*cthe*hf2*sigp

      IF(sig.LT.sigmax*pyr(0)) goto 100


      RETURN

      END


C*********************************************************************


C...PYONIA

C...Generates Upsilon and toponium decays into three gluons

C...or two gluons and a photon.


      SUBROUTINE pyonia(KFL,ECM)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pydat2/kchg(500,4),pmas(500,4),parf(2000),vckm(4,4)

      SAVE /pyjets/,/pydat1/,/pydat2/


C...Printout. Check input parameters.

      IF(mstu(12).GE.1) CALL pylist(0)

      IF(kfl.LT.0.OR.kfl.GT.8) THEN

        CALL pyerrm(16,'(PYONIA:) called with unknown flavour code')

        IF(mstu(21).GE.1) RETURN

      ENDIF

      IF(ecm.LT.parj(127)+2.02d0*parf(101)) THEN

        CALL pyerrm(16,'(PYONIA:) called with too small CM energy')

        IF(mstu(21).GE.1) RETURN

      ENDIF


C...Initial e+e- and onium state (optional).

      nc=0

      IF(mstj(115).GE.2) THEN

        nc=nc+2

        CALL py1ent(nc-1,11,0.5d0*ecm,0d0,0d0)

        k(nc-1,1)=21

        CALL py1ent(nc,-11,0.5d0*ecm,paru(1),0d0)

        k(nc,1)=21

      ENDIF

      kflc=iabs(kfl)

      IF(mstj(115).GE.3.AND.kflc.GE.5) THEN

        nc=nc+1

        kf=110*kflc+3

        mstu10=mstu(10)

        mstu(10)=1

        p(nc,5)=ecm

        CALL py1ent(nc,kf,ecm,0d0,0d0)

        k(nc,1)=21

        k(nc,3)=1

        mstu(10)=mstu10

      ENDIF


C...Choose x1 and x2 according to matrix element.

      ntry=0

  100 x1=pyr(0)

      x2=pyr(0)

      x3=2d0-x1-x2

      IF(x3.GE.1d0.OR.((1d0-x1)/(x2*x3))**2+((1d0-x2)/(x1*x3))**2+

     &((1d0-x3)/(x1*x2))**2.LE.2d0*pyr(0)) goto 100

      ntry=ntry+1

      njet=3

      IF(mstj(101).LE.4) CALL py3ent(nc+1,21,21,21,ecm,x1,x3)

      IF(mstj(101).GE.5) CALL py3ent(-(nc+1),21,21,21,ecm,x1,x3)


C...Photon-gluon-gluon events. Small system modifications. Jet origin.

      mstu(111)=mstj(108)

      IF(mstj(108).EQ.2.AND.(mstj(101).EQ.0.OR.mstj(101).EQ.1))

     &mstu(111)=1

      paru(112)=parj(121)

      IF(mstu(111).EQ.2) paru(112)=parj(122)

      qf=0d0

      IF(kflc.NE.0) qf=kchg(kflc,1)/3d0

      rgam=7.2d0*qf**2*paru(101)/pyalps(ecm**2)

      mk=0

      ecmc=ecm

      IF(pyr(0).GT.rgam/(1d0+rgam)) THEN

        IF(1d0-max(x1,x2,x3).LE.max((parj(126)/ecm)**2,parj(125)))

     &  njet=2

        IF(njet.EQ.2.AND.mstj(101).LE.4) CALL py2ent(nc+1,21,21,ecm)

        IF(njet.EQ.2.AND.mstj(101).GE.5) CALL py2ent(-(nc+1),21,21,ecm)

      ELSE

        mk=1

        ecmc=sqrt(1d0-x1)*ecm

        IF(ecmc.LT.2d0*parj(127)) goto 100

        k(nc+1,1)=1

        k(nc+1,2)=22

        k(nc+1,4)=0

        k(nc+1,5)=0

        IF(mstj(101).GE.5) k(nc+2,4)=mstu(5)*(nc+3)

        IF(mstj(101).GE.5) k(nc+2,5)=mstu(5)*(nc+3)

        IF(mstj(101).GE.5) k(nc+3,4)=mstu(5)*(nc+2)

        IF(mstj(101).GE.5) k(nc+3,5)=mstu(5)*(nc+2)

        njet=2

        IF(ecmc.LT.4d0*parj(127)) THEN

          mstu10=mstu(10)

          mstu(10)=1

          p(nc+2,5)=ecmc

          CALL py1ent(nc+2,83,0.5d0*(x2+x3)*ecm,paru(1),0d0)

          mstu(10)=mstu10

          njet=0

        ENDIF

      ENDIF

      DO 110 ip=nc+1,n

        k(ip,3)=k(ip,3)+(mstj(115)/2)+(kflc/5)*(mstj(115)/3)*(nc-1)

  110 CONTINUE


C...Differential cross-sections. Upper limit for cross-section.

      IF(mstj(106).EQ.1) THEN

        sq2=sqrt(2d0)

        hf1=1d0-parj(131)*parj(132)

        hf3=parj(133)**2

        ct13=(x1*x3-2d0*x1-2d0*x3+2d0)/(x1*x3)

        st13=sqrt(1d0-ct13**2)

        sigl=0.5d0*x3**2*((1d0-x2)**2+(1d0-x3)**2)*st13**2

        sigu=(x1*(1d0-x1))**2+(x2*(1d0-x2))**2+(x3*(1d0-x3))**2-sigl

        sigt=0.5d0*sigl

        sigi=(sigl*ct13/st13+0.5d0*x1*x3*(1d0-x2)**2*st13)/sq2

        sigmax=(2d0*hf1+hf3)*abs(sigu)+2d0*(hf1+hf3)*abs(sigl)+2d0*(hf1+

     &  2d0*hf3)*abs(sigt)+2d0*sq2*(hf1+2d0*hf3)*abs(sigi)


C...Angular orientation of event.

  120   chi=paru(2)*pyr(0)

        cthe=2d0*pyr(0)-1d0

        phi=paru(2)*pyr(0)

        cchi=cos(chi)

        schi=sin(chi)

        c2chi=cos(2d0*chi)

        s2chi=sin(2d0*chi)

        the=acos(cthe)

        sthe=sin(the)

        c2phi=cos(2d0*(phi-parj(134)))

        s2phi=sin(2d0*(phi-parj(134)))

        sig=((1d0+cthe**2)*hf1+sthe**2*c2phi*hf3)*sigu+2d0*(sthe**2*hf1-

     &  sthe**2*c2phi*hf3)*sigl+2d0*(sthe**2*c2chi*hf1+((1d0+cthe**2)*

     &  c2chi*c2phi-2d0*cthe*s2chi*s2phi)*hf3)*sigt-

     &  2d0*sq2*(2d0*sthe*cthe*cchi*hf1-2d0*sthe*

     &  (cthe*cchi*c2phi-schi*s2phi)*hf3)*sigi

        IF(sig.LT.sigmax*pyr(0)) goto 120

        CALL pyrobo(nc+1,n,0d0,chi,0d0,0d0,0d0)

        CALL pyrobo(nc+1,n,the,phi,0d0,0d0,0d0)

      ENDIF


C...Generate parton shower. Rearrange along strings and check.

      IF(mstj(101).GE.5.AND.njet.GE.2) THEN

        CALL pyshow(nc+mk+1,-njet,ecmc)

        mstj14=mstj(14)

        IF(mstj(105).EQ.-1) mstj(14)=-1

        IF(mstj(105).GE.0) mstu(28)=0

        CALL pyprep(0)

        mstj(14)=mstj14

        IF(mstj(105).GE.0.AND.mstu(28).NE.0) goto 100

      ENDIF


C...Generate fragmentation. Information for PYTABU:

      IF(mstj(105).EQ.1) CALL pyexec

      mstu(161)=110*kflc+3

      mstu(162)=0


      RETURN

      END


C*********************************************************************


C...PYBOOK

C...Books a histogram.


      SUBROUTINE pybook(ID,TITLE,NX,XL,XU)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/

C...Local character variables.

      CHARACTER title*(*), titfx*60


C...Check that input is sensible. Find initial address in memory.

      IF(id.LE.0.OR.id.GT.ihist(1)) CALL pyerrm(28,

     &'(PYBOOK:) not allowed histogram number')

      IF(nx.LE.0.OR.nx.GT.100) CALL pyerrm(28,

     &'(PYBOOK:) not allowed number of bins')

      IF(xl.GE.xu) CALL pyerrm(28,

     &'(PYBOOK:) x limits in wrong order')

      indx(id)=ihist(4)

      ihist(4)=ihist(4)+28+nx

      IF(ihist(4).GT.ihist(2)) CALL pyerrm(28,

     &'(PYBOOK:) out of histogram space')

      is=indx(id)


C...Store histogram size and reset contents.

      bin(is+1)=nx

      bin(is+2)=xl

      bin(is+3)=xu

      bin(is+4)=(xu-xl)/nx

      CALL pynull(id)


C...Store title by conversion to integer to double precision.

      titfx=title//' '

      DO 100 it=1,20

        bin(is+8+nx+it)=256**2*ichar(titfx(3*it-2:3*it-2))+

     &  256*ichar(titfx(3*it-1:3*it-1))+ichar(titfx(3*it:3*it))

  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYFILL

C...Fills entry in histogram.


      SUBROUTINE pyfill(ID,X,W)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/


C...Find initial address in memory. Increase number of entries.

      is=indx(id)

      bin(is+5)=bin(is+5)+1d0


C...Find bin in x, including under/overflow, and fill.

      IF(x.LT.bin(is+2)) THEN

        bin(is+6)=bin(is+6)+w

      ELSEIF(x.GE.bin(is+3)) THEN

        bin(is+8)=bin(is+8)+w

      ELSE

        bin(is+7)=bin(is+7)+w

        ix=(x-bin(is+2))/bin(is+4)

        ix=max(0,min(nint(bin(is+1))-1,ix))

        bin(is+9+ix)=bin(is+9+ix)+w

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYFACT

C...Multiplies histogram contents by factor.


      SUBROUTINE pyfact(ID,F)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/


C...Find initial address in memory. Multiply all contents bins.

      is=indx(id)

      DO 100 ix=is+6,is+8+nint(bin(is+1))

        bin(ix)=f*bin(ix)

  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYOPER

C...Performs operations between histograms.


      SUBROUTINE pyoper(ID1,OPER,ID2,ID3,F1,F2)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/

C...Character variable.

      CHARACTER oper*(*)


C...Find initial addresses in memory, and histogram size.

      is1=indx(id1)

      is2=indx(min(ihist(1),max(1,id2)))

      is3=indx(min(ihist(1),max(1,id3)))

      nx=nint(bin(is3+1))

      IF(oper.EQ.'M'.AND.id3.EQ.0) nx=nint(bin(is2+1))


C...Update info on number of histogram entries.

      IF(oper.EQ.'+'.OR.oper.EQ.'-'.OR.oper.EQ.'*'.OR.oper.EQ.'/') THEN

        bin(is3+5)=bin(is1+5)+bin(is2+5)

      ELSEIF(oper.EQ.'A'.OR.oper.EQ.'S'.OR.oper.EQ.'L') THEN

        bin(is3+5)=bin(is1+5)

      ENDIF


C...Operations on pair of histograms: addition, subtraction,

C...multiplication, division.

      IF(oper.EQ.'+') THEN

        DO 100 ix=6,8+nx

          bin(is3+ix)=f1*bin(is1+ix)+f2*bin(is2+ix)

  100   CONTINUE

      ELSEIF(oper.EQ.'-') THEN

        DO 110 ix=6,8+nx

          bin(is3+ix)=f1*bin(is1+ix)-f2*bin(is2+ix)

  110   CONTINUE

      ELSEIF(oper.EQ.'*') THEN

        DO 120 ix=6,8+nx

          bin(is3+ix)=f1*bin(is1+ix)*f2*bin(is2+ix)

  120   CONTINUE

      ELSEIF(oper.EQ.'/') THEN

        DO 130 ix=6,8+nx

          fa2=f2*bin(is2+ix)

          IF(abs(fa2).LE.1d-20) THEN

            bin(is3+ix)=0d0

          ELSE

            bin(is3+ix)=f1*bin(is1+ix)/fa2

          ENDIF

  130   CONTINUE


C...Operations on single histogram: multiplication+addition,

C...square root+addition, logarithm+addition.

      ELSEIF(oper.EQ.'A') THEN

        DO 140 ix=6,8+nx

          bin(is3+ix)=f1*bin(is1+ix)+f2

  140   CONTINUE

      ELSEIF(oper.EQ.'S') THEN

        DO 150 ix=6,8+nx

          bin(is3+ix)=f1*sqrt(max(0d0,bin(is1+ix)))+f2

  150   CONTINUE

      ELSEIF(oper.EQ.'L') THEN

        zmin=1d20

        DO 160 ix=9,8+nx

          IF(bin(is1+ix).LT.zmin.AND.bin(is1+ix).GT.1d-20)

     &    zmin=0.8d0*bin(is1+ix)

  160   CONTINUE

        DO 170 ix=6,8+nx

          bin(is3+ix)=f1*log10(max(zmin,bin(is1+ix)))+f2

  170   CONTINUE


C...Operation on two or three histograms: average and

C...standard deviation.

      ELSEIF(oper.EQ.'M') THEN

        DO 180 ix=6,8+nx

          IF(abs(bin(is1+ix)).LE.1d-20) THEN

            bin(is2+ix)=0d0

          ELSE

            bin(is2+ix)=bin(is2+ix)/bin(is1+ix)

          ENDIF

          IF(id3.NE.0) THEN

            IF(abs(bin(is1+ix)).LE.1d-20) THEN

              bin(is3+ix)=0d0

            ELSE

              bin(is3+ix)=sqrt(max(0d0,bin(is3+ix)/bin(is1+ix)-

     &        bin(is2+ix)**2))

            ENDIF

          ENDIF

          bin(is1+ix)=f1*bin(is1+ix)

  180   CONTINUE

      ENDIF


      RETURN

      END


C*********************************************************************


C...PYHIST

C...Prints and resets all histograms.


      SUBROUTINE pyhist


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/


C...Loop over histograms, print and reset used ones.

      DO 100 id=1,ihist(1)

        is=indx(id)

        IF(is.NE.0.AND.nint(bin(is+5)).GT.0) THEN

          CALL pyplot(id)

          CALL pynull(id)

        ENDIF

  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYPLOT

C...Prints a histogram (but does not reset it).


      SUBROUTINE pyplot(ID)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pydat1/,/pybins/

C...Local arrays and character variables.

      dimension idati(6), irow(100), ifra(100), dyac(10)

      CHARACTER title*60, out*100, cha(0:11)*1


C...Steps in histogram scale. Character sequence.

      DATA dyac/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/

      DATA cha/'0','1','2','3','4','5','6','7','8','9','X','-'/


C...Find initial address in memory; skip if empty histogram.

      is=indx(id)

      IF(nint(bin(is+5)).LE.0) THEN

        WRITE(mstu(11),5000) id

        RETURN

      ENDIF


C...Number of histogram lines and x bins.

      lin=ihist(3)-18

      nx=nint(bin(is+1))


C...Extract title by conversion from double precision via integer.

      DO 100 it=1,20

        ieq=nint(bin(is+8+nx+it))

        title(3*it-2:3*it)=char(ieq/256**2)//char(mod(ieq,256**2)/256)

     &  //char(mod(ieq,256))

  100 CONTINUE


C...Find time; print title.

      CALL pytime(idati)

      IF(idati(1).GT.0) THEN

        WRITE(mstu(11),5100) id, title, (idati(j),j=1,5)

      ELSE

        WRITE(mstu(11),5200) id, title

      ENDIF


C...Find minimum and maximum bin content.

      ymin=bin(is+9)

      ymax=bin(is+9)

      DO 110 ix=is+10,is+8+nx

        IF(bin(ix).LT.ymin) ymin=bin(ix)

        IF(bin(ix).GT.ymax) ymax=bin(ix)

  110 CONTINUE


C...Determine scale and step size for y axis.

      IF(ymax-ymin.GT.lin*dyac(1)*1d-9) THEN

        IF(ymin.GT.0d0.AND.ymin.LT.0.1d0*ymax) ymin=0d0

        IF(ymax.LT.0d0.AND.ymax.GT.0.1d0*ymin) ymax=0d0

        ipot=int(log10(ymax-ymin)+10d0)-10

        IF(ymax-ymin.LT.lin*dyac(1)*10d0**ipot) ipot=ipot-1

        IF(ymax-ymin.GT.lin*dyac(10)*10d0**ipot) ipot=ipot+1

        dely=dyac(1)

        DO 120 idel=1,9

          IF(ymax-ymin.GE.lin*dyac(idel)*10d0**ipot) dely=dyac(idel+1)

  120   CONTINUE

        dy=dely*10d0**ipot


C...Convert bin contents to integer form; fractional fill in top row.

        DO 130 ix=1,nx

          cta=abs(bin(is+8+ix))/dy

          irow(ix)=sign(cta+0.95d0,bin(is+8+ix))

          ifra(ix)=10d0*(cta+1.05d0-dble(int(cta+0.95d0)))

  130   CONTINUE

        irmi=sign(abs(ymin)/dy+0.95d0,ymin)

        irma=sign(abs(ymax)/dy+0.95d0,ymax)


C...Print histogram row by row.

        DO 150 ir=irma,irmi,-1

          IF(ir.EQ.0) goto 150

          out=' '

          DO 140 ix=1,nx

            IF(ir.EQ.irow(ix)) out(ix:ix)=cha(ifra(ix))

            IF(ir*(irow(ix)-ir).GT.0) out(ix:ix)=cha(10)

  140     CONTINUE

          WRITE(mstu(11),5300) ir*dely, ipot, out

  150   CONTINUE


C...Print sign and value of bin contents.

        ipot=int(log10(max(ymax,-ymin))+10.0001d0)-10

        out=' '

        DO 160 ix=1,nx

          IF(bin(is+8+ix).LT.-10d0**(ipot-4)) out(ix:ix)=cha(11)

          irow(ix)=nint(10d0**(3-ipot)*abs(bin(is+8+ix)))

  160   CONTINUE

        WRITE(mstu(11),5400) out

        DO 180 ir=4,1,-1

          DO 170 ix=1,nx

            out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))

  170     CONTINUE

          WRITE(mstu(11),5500) ipot+ir-4, out

  180   CONTINUE


C...Print sign and value of lower bin edge.

        ipot=int(log10(max(-bin(is+2),bin(is+3)-bin(is+4)))+

     &  10.0001d0)-10

        out=' '

        DO 190 ix=1,nx

          IF(bin(is+2)+(ix-1)*bin(is+4).LT.-10d0**(ipot-3))

     &    out(ix:ix)=cha(11)

          irow(ix)=nint(10d0**(2-ipot)*abs(bin(is+2)+(ix-1)*bin(is+4)))

  190   CONTINUE

        WRITE(mstu(11),5600) out

        DO 210 ir=3,1,-1

          DO 200 ix=1,nx

            out(ix:ix)=cha(mod(irow(ix),10**ir)/10**(ir-1))

  200     CONTINUE

          WRITE(mstu(11),5500) ipot+ir-3, out

  210   CONTINUE

      ENDIF


C...Calculate and print statistics.

      csum=0d0

      cxsum=0d0

      cxxsum=0d0

      DO 220 ix=1,nx

        cta=abs(bin(is+8+ix))

        x=bin(is+2)+(ix-0.5d0)*bin(is+4)

        csum=csum+cta

        cxsum=cxsum+cta*x

        cxxsum=cxxsum+cta*x**2

  220 CONTINUE

      xmean=cxsum/max(csum,1d-20)

      xrms=sqrt(max(0d0,cxxsum/max(csum,1d-20)-xmean**2))

      WRITE(mstu(11),5700) nint(bin(is+5)),xmean,bin(is+6),

     &bin(is+2),bin(is+7),xrms,bin(is+8),bin(is+3)


C...Formats for output.

 5000 FORMAT(/5x,'Histogram no',i5,' : no entries')

 5100 FORMAT('1'/5x,'Histogram no',i5,6x,a60,5x,i4,'-',i2,'-',i2,1x,

     &i2,':',i2/)

 5200 FORMAT('1'/5x,'Histogram no',i5,6x,a60/)

 5300 FORMAT(2x,f7.2,'*10**',i2,3x,a100)

 5400 FORMAT(/8x,'Contents',3x,a100)

 5500 FORMAT(9x,'*10**',i2,3x,a100)

 5600 FORMAT(/8x,'Low edge',3x,a100)

 5700 FORMAT(/5x,'Entries  =',i12,1p,6x,'Mean =',d12.4,6x,'Underflow ='

     &,d12.4,6x,'Low edge  =',d12.4/5x,'All chan =',d12.4,6x,

     &'Rms  =',d12.4,6x,'Overflow  =',d12.4,6x,'High edge =',d12.4)


      RETURN

      END


C*********************************************************************


C...PYNULL

C...Resets bin contents of a histogram.


      SUBROUTINE pynull(ID)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/


      is=indx(id)

      DO 100 ix=is+5,is+8+nint(bin(is+1))

        bin(ix)=0d0

  100 CONTINUE


      RETURN

      END


C*********************************************************************


C...PYDUMP

C...Dumps histogram contents on file for reading by other program.

C...Can also read back own dump.


      SUBROUTINE pydump(MDUMP,LFN,NHI,IHI)


C...Double precision declaration.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

C...Commonblock.

      common/pybins/ihist(4),indx(1000),bin(20000)

      SAVE /pybins/

C...Local arrays and character variables.

      dimension ihi(*),iss(100),val(5)

      CHARACTER title*60,format*13


C...Dump all histograms that have been booked,

C...including titles and ranges, one after the other.

      IF(mdump.EQ.1) THEN


C...Loop over histograms and find which are wanted and booked.

        IF(nhi.LE.0) THEN

          nw=ihist(1)

        ELSE

          nw=nhi

        ENDIF

        DO 130 iw=1,nw

          IF(nhi.EQ.0) THEN

            id=iw

          ELSE

            id=ihi(iw)

          ENDIF

          is=indx(id)

          IF(is.NE.0) THEN


C...Write title and histogram size.

            nx=nint(bin(is+1))

            DO 100 it=1,20

              ieq=nint(bin(is+8+nx+it))

              title(3*it-2:3*it)=char(ieq/256**2)//

     &        char(mod(ieq,256**2)/256)//char(mod(ieq,256))

  100       CONTINUE

            WRITE(lfn,5100) id,title

            WRITE(lfn,5200) nx,bin(is+2),bin(is+3)


C...Write histogram contents, in groups of five.

            DO 120 ixg=1,(nx+4)/5

              DO 110 ixv=1,5

                ix=5*ixg+ixv-5

                IF(ix.LE.nx) THEN

                  val(ixv)=bin(is+8+ix)

                ELSE

                  val(ixv)=0d0

                ENDIF

  110         CONTINUE

              WRITE(lfn,5300) (val(ixv),ixv=1,5)

  120       CONTINUE


C...Go to next histogram; finish.

          ELSEIF(nhi.GT.0) THEN

            CALL pyerrm(8,'(PYDUMP:) unknown histogram number')

          ENDIF

  130   CONTINUE


C...Read back in histograms dumped MDUMP=1.

      ELSEIF(mdump.EQ.2) THEN


C...Read histogram number, title and range, and book.

  140   READ(lfn,5100,end=170) id,title

        READ(lfn,5200) nx,xl,xu

        CALL pybook(id,title,nx,xl,xu)

        is=indx(id)


C...Read histogram contents, in groups of five.

        DO 160 ixg=1,(nx+4)/5

          READ(lfn,5300) (val(ixv),ixv=1,5)

          DO 150 ixv=1,5

            ix=5*ixg+ixv-5

            IF(ix.LE.nx) bin(is+8+ix)=val(ixv)

  150     CONTINUE

  160   CONTINUE


C...Go to next histogram; finish.

        goto 140

  170   CONTINUE


C...Write histogram contents in column format,

C...convenient e.g. for GNUPLOT input.

      ELSEIF(mdump.EQ.3) THEN


C...Find addresses to wanted histograms.

        nss=0

        IF(nhi.LE.0) THEN

          nw=ihist(1)

        ELSE

          nw=nhi

        ENDIF

        DO 180 iw=1,nw

          IF(nhi.EQ.0) THEN

            id=iw

          ELSE

            id=ihi(iw)

          ENDIF

          is=indx(id)

          IF(is.NE.0.AND.nss.LT.100) THEN

            nss=nss+1

            iss(nss)=is

          ELSEIF(nss.GE.100) THEN

            CALL pyerrm(8,'(PYDUMP:) too many histograms requested')

          ELSEIF(nhi.GT.0) THEN

            CALL pyerrm(8,'(PYDUMP:) unknown histogram number')

          ENDIF

  180   CONTINUE


C...Check that they have common number of x bins. Fix format.

        nx=nint(bin(iss(1)+1))

        DO 190 iw=2,nss

          IF(nint(bin(iss(iw)+1)).NE.nx) THEN

            CALL pyerrm(8,'(PYDUMP:) different number of bins')

            RETURN

          ENDIF

  190   CONTINUE

        format='(1P,000D12.4)'

        WRITE(FORMAT(5:7),'(I3)') nss+1


C...Write histogram contents; first column x values.

        DO 200 ix=1,nx

          x=bin(iss(1)+2)+(ix-0.5d0)*bin(iss(1)+4)

          WRITE(lfn,format) x, (bin(iss(iw)+8+ix),iw=1,nss)

  200   CONTINUE


      ENDIF


C...Formats for output.

 5100 FORMAT(i5,5x,a60)

 5200 FORMAT(i5,1p,2d12.4)

 5300 FORMAT(1p,5d12.4)


      RETURN

      END


C*********************************************************************


C...PYKCUT

C...Dummy routine, which the user can replace in order to make cuts on

C...the kinematics on the parton level before the matrix elements are

C...evaluated and the event is generated. The cross-section estimates

C...will automatically take these cuts into account, so the given

C...values are for the allowed phase space region only. MCUT=0 means

C...that the event has passed the cuts, MCUT=1 that it has failed.


      SUBROUTINE pykcut(MCUT)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pydat1/,/pyint1/,/pyint2/


C...Set default value (accepting event) for MCUT.

      mcut=0


C...Read out subprocess number.

      isub=mint(1)

      istsb=iset(isub)


C...Read out tau, y*, cos(theta), tau' (where defined, else =0).

      tau=vint(21)

      yst=vint(22)

      cth=0d0

      IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)

      taup=0d0

      IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)


C...Calculate x_1, x_2, x_F.

      IF(istsb.LE.2.OR.istsb.GE.5) THEN

        x1=sqrt(tau)*exp(yst)

        x2=sqrt(tau)*exp(-yst)

      ELSE

        x1=sqrt(taup)*exp(yst)

        x2=sqrt(taup)*exp(-yst)

      ENDIF

      xf=x1-x2


C...Calculate shat, that, uhat, p_T^2.

      shat=tau*vint(2)

      sqm3=vint(63)

      sqm4=vint(64)

      rm3=sqm3/shat

      rm4=sqm4/shat

      be34=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4))

      rpts=4d0*vint(71)**2/shat

      be34l=sqrt(max(0d0,(1d0-rm3-rm4)**2-4d0*rm3*rm4-rpts))

      rm34=2d0*rm3*rm4

      rsqm=1d0+rm34

      rthm=(4d0*rm3*rm4+rpts)/(1d0-rm3-rm4+be34l)

      that=-0.5d0*shat*max(rthm,1d0-rm3-rm4-be34*cth)

      uhat=-0.5d0*shat*max(rthm,1d0-rm3-rm4+be34*cth)

      pt2=max(vint(71)**2,0.25d0*shat*be34**2*(1d0-cth**2))


C...Decisions by user to be put here.


C...Stop program if this routine is ever called.

C...You should not copy these lines to your own routine.

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link your PYKCUT routine ',

     &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYEVWT

C...Dummy routine, which the user can replace in order to multiply the

C...standard PYTHIA differential cross-section by a process- and

C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds

C...to generation of weighted events, with weight 1/WTXS, while for

C...MSTP(142)=2 it corresponds to a modification of the underlying

C...physics.


      SUBROUTINE pyevwt(WTXS)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyint1/mint(400),vint(400)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      SAVE /pydat1/,/pyint1/,/pyint2/


C...Set default weight for WTXS.

      wtxs=1d0


C...Read out subprocess number.

      isub=mint(1)

      istsb=iset(isub)


C...Read out tau, y*, cos(theta), tau' (where defined, else =0).

      tau=vint(21)

      yst=vint(22)

      cth=0d0

      IF(istsb.EQ.2.OR.istsb.EQ.4) cth=vint(23)

      taup=0d0

      IF(istsb.GE.3.AND.istsb.LE.5) taup=vint(26)


C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.

      x1=vint(41)

      x2=vint(42)

      xf=x1-x2

      shat=vint(44)

      that=vint(45)

      uhat=vint(46)

      pt2=vint(48)


C...Modifications by user to be put here.


C...Stop program if this routine is ever called.

C...You should not copy these lines to your own routine.

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link your PYEVWT routine ',

     &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYUPIN

C...Dummy copy of routine to be called by user to set up a user-defined

C...process.


      SUBROUTINE pyupin(ISUB,TITLE,SIGMAX)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyint2/iset(500),kfpr(500,2),coef(500,20),icol(40,4,2)

      common/pyint6/proc(0:500)

      CHARACTER proc*28

      SAVE /pydat1/,/pyint2/,/pyint6/

C...Local character variable.

      CHARACTER*(*) title


C...Check that subprocess number free.

      IF(isub.LT.1.OR.isub.GT.200.OR.iset(isub).GE.0) THEN

        WRITE(mstu(11),5000) isub

        stop

      ENDIF


C...Fill information on new process.

      iset(isub)=11

      coef(isub,1)=sigmax

      proc(isub)=title//' '


C...Format for error output.

 5000 FORMAT(1x,'Error: user-defined subprocess code ',i4,

     &' not allowed.'//1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYUPEV

C...Dummy routine, to be replaced by user. When called from PYTHIA

C...the subprocess number ISUB will be given, and PYUPEV is supposed

C...to generate an event of this type, to be stored in the PYUPPR

C...commonblock. SIGEV gives the differential cross-section associated

C...with the event, i.e. the acceptance probability of the event is

C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN

C...call.


      SUBROUTINE pyupev(ISUB,SIGEV)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      common/pyuppr/nup,kup(20,7),nfup,ifup(10,2),pup(20,5),q2up(0:10)

      SAVE /pydat1/,/pyuppr/


C...Stop program if this routine is ever called.

C...You should not copy these lines to your own routine.

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop

      sigev=isub


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link your PYUPEV routine ',

     &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PDFSET

C...Dummy routine, to be removed when PDFLIB is to be linked.


      SUBROUTINE pdfset(PARM,VALUE)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local arrays and character variables.

      CHARACTER*20 parm(20)

      DOUBLE PRECISION value(20)


C...Stop program if this routine is ever called.

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop

      parm(20)=parm(1)

      value(20)=value(1)


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/

     &1x,'Dummy routine PDFSET in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...STRUCTM

C...Dummy routine, to be removed when PDFLIB is to be linked.


      SUBROUTINE structm(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pydat1/

C...Local variables

      DOUBLE PRECISION xx,qq,upv,dnv,usea,dsea,str,chm,bot,top,glu


C...Stop program if this routine is ever called.

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop

      upv=xx+qq

      dnv=xx+2d0*qq

      usea=xx+3d0*qq

      dsea=xx+4d0*qq

      str=xx+5d0*qq

      chm=xx+6d0*qq

      bot=xx+7d0*qq

      top=xx+8d0*qq

      glu=xx+9d0*qq


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link PDFLIB correctly.'/

     &1x,'Dummy routine STRUCTM in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYTAUD

C...Dummy routine, to be replaced by user, to handle the decay of a

C...polarized tau lepton.

C...Input:

C...ITAU is the position where the decaying tau is stored in /PYJETS/.

C...IORIG is the position where the mother of the tau is stored;

C...     is 0 when the mother is not stored.

C...KFORIG is the flavour of the mother of the tau;

C...     is 0 when the mother is not known.

C...Note that IORIG=0 does not necessarily imply KFORIG=0;

C...     e.g. in B hadron semileptonic decays the W  propagator

C...     is not explicitly stored but the W code is still unambiguous.

C...Output:

C...NDECAY is the number of decay products in the current tau decay.

C...These decay products should be added to the /PYJETS/ common block,

C...in positions N+1 through N+NDECAY. For each product I you must

C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),

C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.


      SUBROUTINE pytaud(ITAU,IORIG,KFORIG,NDECAY)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

C...Commonblocks.

      common/pyjets/n,npad,k(4000,5),p(4000,5),v(4000,5)

      common/pydat1/mstu(200),paru(200),mstj(200),parj(200)

      SAVE /pyjets/,/pydat1/


C...Stop program if this routine is ever called.

C...You should not copy these lines to your own routine.

      ndecay=itau+iorig+kforig

      WRITE(mstu(11),5000)

      IF(pyr(0).LT.10d0) stop


C...Format for error printout.

 5000 FORMAT(1x,'Error: you did not link your PYTAUD routine ',

     &'correctly.'/1x,'Dummy routine in PYTHIA file called instead.'/

     &1x,'Execution stopped!')


      RETURN

      END


C*********************************************************************


C...PYTIME

C...Finds current date and time.

C...Since this task is not standardized in Fortran 77, the routine

C...is dummy, to be replaced by the user. Examples are given for

C...the Fortran 90 routine and DEC Fortran 77, and what to do if

C...you do not have access to suitable routines.


      SUBROUTINE pytime(IDATI)


C...Double precision and integer declarations.

      IMPLICIT DOUBLE PRECISION(a-h, o-z)

      INTEGER pyk,pychge,pycomp

      CHARACTER*8 atime

C...Local array.

      INTEGER idati(6),idtemp(3)


C...Example 0: if you do not have suitable routines.

      DO 100 j=1,6

        idati(j)=0

  100 CONTINUE


C...Example 1: Fortran 90 routine.

C      INTEGER IVAL(8)

C      CALL DATE_AND_TIME(VALUES=IVAL)

C      IDATI(1)=IVAL(1)

C      IDATI(2)=IVAL(2)

C      IDATI(3)=IVAL(3)

C      IDATI(4)=IVAL(5)

C      IDATI(5)=IVAL(6)

C      IDATI(6)=IVAL(7)


C...Example 2: DEC Fortran 77.

C      CALL IDATE(IMON,IDAY,IYEAR)

C      IDATI(1)=1900+IYEAR

C      IDATI(2)=IMON

C      IDATI(3)=IDAY

C      CALL ITIME(IHOUR,IMIN,ISEC)

C      IDATI(4)=IHOUR

C      IDATI(5)=IMIN

C      IDATI(6)=ISEC


C...Example 3: DEC Fortran

C      CALL IDATE(IMON,IDAY,IYEAR)

C      IDATI(1)=1900+IYEAR

C      IDATI(2)=IMON

C      IDATI(3)=IDAY

C      CALL TIME(ATIME)

C      IHOUR=0

C      IMIN=0

C      ISEC=0

C      READ(ATIME(1:2),'(I2)') IHOUR

C      READ(ATIME(4:5),'(I2)') IMIN

C      READ(ATIME(7:8),'(I2)') ISEC

C      IDATI(4)=IHOUR

C      IDATI(5)=IMIN

C      IDATI(6)=ISEC


C...Example 4: GNU LINUX libU77.

C      CALL IDATE(IDTEMP)

C      IDATI(1)=IDTEMP(3)

C      IDATI(2)=IDTEMP(2)

C      IDATI(3)=IDTEMP(1)

C      CALL ITIME(IDTEMP)

C      IDATI(4)=IDTEMP(1)

C      IDATI(5)=IDTEMP(2)

C      IDATI(6)=IDTEMP(3)


      RETURN

      END