pythia6152.f

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*                   Physics Department, UC Davis                   **
C*             One Shields Avenue, Davis, CA 95616, USA             **
C*                   phone + 1 - 530 - 752 - 2661                   **
C*                E-mail mrenna@physics.ucdavis.edu                 **
C*                                                                  **
C*         Several parts are written by Hans-Uno Bengtsson          **
C*          PYSHOW is written together with Mats Bengtsson          **
C*     advanced popcorn baryon production written by Patrik Eden    **
C*    code for virtual photons mainly written by Christer Friberg   **
C*    code for low-mass strings mainly written by Emanuel Norrbin   **
C*        Bose-Einstein code mainly written by Leif Lonnblad        **
C*      CTEQ  parton distributions are by the CTEQ collaboration    **
C*      GRV 94 parton distributions are by Glueck, Reya and Vogt    **
C*   SaS photon parton distributions together with Gerhard Schuler  **
C*     g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt     **
C*         MSSM Higgs mass calculation code by M. Carena,           **
C*           J.R. Espinosa, M. Quiros and C.E.M. Wagner             **
C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **
C*                                                                  **
C*   The latest program version and documentation is found on WWW   **
C*            http://www.thep.lu.se/~torbjorn/Pythia.html           **
C*                                                                  **
C*              Copyright Torbjorn Sjostrand, Lund 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   PYGAGA   to handle lepton -> lepton + gamma branchings        *
C  S   PYRAND   to select subprocess and kinematics for event        *
C  S   PYSCAT   to set up kinematics and colour flow of event        *
C  S   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   PYDISG   to set up kinematics, remnant and showers for DIS    *
C  S   PYDOCU   to compute cross-sections and handle documentation   *
C  S   PYFRAM   to perform boosts between different frames           *
C  S   PYWIDT   to calculate full and partial widths of resonances   *
C  S   PYOFSH   to calculate partial width into off-shell channels   *
C  S   PYRECO   to handle colour reconnection in W+W- events         *
C  S   PYKLIM   to calculate borders of allowed kinematical region   *
C  S   PYKMAP   to construct value of kinematical variable           *
C  S   PYSIGH   to calculate differential cross-sections             *
C  S   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 proton parton distributions  *
C  S   PYGRVM   to evaluate the GRV 94M proton parton distributions  *
C  S   PYGRVD   to evaluate the GRV 94D proton parton distributions  *
C  F   PYGRVV   auxiliary to the PYGRV* routines                     *
C  F   PYGRVW   auxiliary to the PYGRV* routines                     *
C  F   PYGRVS   auxiliary to the PYGRV* routines                     *
C  F   PYCT5L   to evaluate the CTEQ 5L proton parton distributions  *
C  F   PYCT5M   to evaluate the CTEQ 5M1 proton parton distributions *
C  S   PYPDPO   to evaluate old proton parton distributions          *
C  F   PYHFTH   to evaluate threshold factor for heavy flavour       *
C  S   PYSPLI   to find flavours left in hadron when one removed     *
C  F   PYGAMM   to evaluate ordinary Gamma function Gamma(x)         *
C  S   PYWAUX   to evaluate auxiliary functions W1(s) and W2(s)      *
C  S   PYI3AU   to evaluate auxiliary function I3(s,t,u,v)           *
C  F   PYSPEN   to evaluate Spence (dilogarithm) function Sp(x)      *
C  S   PYQQBH   to evaluate matrix element for g + g -> Q + Qbar + H *
C                                                                    *
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  S   PYTECM   to calculate techni_rho/omega masses                 *
C  S   PYEICG   to calculate eigenvalues of a 4*4 complex matrix     *
C                                                                    *
C  S   PY1ENT   to fill one entry (= parton or particle)             *
C  S   PY2ENT   to fill two entries                                  *
C  S   PY3ENT   to fill three entries                                *
C  S   PY4ENT   to fill four entries                                 *
C  S   PY2FRM   to interface to generic two-fermion generator        *
C  S   PY4FRM   to interface to generic four-fermion generator       *
C  S   PY6FRM   to interface to generic six-fermion generator        *
C  S   PY4JET   to generate a shower from a given 4-parton config    *
C  S   PY4JTW   to evaluate the weight od a shower history for above *
C  S   PY4JTS   to set up the parton configuration for above         *
C  S   PYJOIN   to connect entries with colour flow information      *
C  S   PYGIVE   to fill (or query) commonblock variables             *
C  S   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   PYDCYK   to select parton and hadron flavours in decays       *
C  S   PYKFDI   to select parton and hadron flavours in fragm        *
C  S   PYNMES   to select number of popcorn mesons                   *
C  S   PYKFIN   to calculate falvour prod. ratios from input params. *
C  S   PYPTDI   to select transverse momenta in fragm                *
C  S   PYZDIS   to select longitudinal scaling variable in fragm     *
C  S   PYSHOW   to do timelike parton shower evolution               *
C  S   PYBOEI   to include Bose-Einstein effects (crudely)           *
C  S   PYBESQ   auxiliary to PYBOEI                                  *
C  F   PYMASS   to give the mass of a particle or parton             *
C  F   PYMRUN   to give the running MSbar mass of a quark            *
C  S   PYNAME   to give the name of a particle or parton             *
C  F   PYCHGE   to give three times the electric charge              *
C  F   PYCOMP   to compress standard KF flavour code to internal KC  *
C  S   PYERRM   to write error messages and abort faulty run         *
C  F   PYALEM   to give the alpha_electromagnetic value              *
C  F   PYALPS   to give the alpha_strong value                       *
C  F   PYANGL   to give the angle from known x and y components      *
C  F   PYR      to provide a random number generator                 *
C  S   PYRGET   to save the state of the random number generator     *
C  S   PYRSET   to set the state of the random number generator      *
C  S   PYROBO   to rotate and/or boost an event                      *
C  S   PYEDIT   to remove unwanted entries from record               *
C  S   PYLIST   to list event record or particle data                *
C  S   PYLOGO   to write a logo                                      *
C  S   PYUPDA   to update particle data                              *
C  F   PYK      to provide integer-valued event information          *
C  F   PYP      to provide real-valued event information             *
C  S   PYSPHE   to perform sphericity analysis                       *
C  S   PYTHRU   to perform thrust analysis                           *
C  S   PYCLUS   to perform three-dimensional cluster analysis        *
C  S   PYCELL   to perform cluster analysis in (eta, phi, E_T)       *
C  S   PYJMAS   to give high and low jet mass of event               *
C  S   PYFOWO   to give Fox-Wolfram moments                          *
C  S   PYTABU   to analyze events, with tabular output               *
C                                                                    *
C  S   PYEEVT   to administrate the generation of an e+e- event      *
C  S   PYXTEE   to give the total cross-section at given CM energy   *
C  S   PYRADK   to generate initial state photon radiation           *
C  S   PYXKFL   to select flavour of primary qqbar pair              *
C  S   PYXJET   to select (matrix element) jet multiplicity          *
C  S   PYX3JT   to select kinematics of three-jet event              *
C  S   PYX4JT   to select kinematics of four-jet event               *
C  S   PYXDIF   to select angular orientation of event               *
C  S   PYONIA   to perform generation of onium decay to gluons       *
C                                                                    *
C  S   PYBOOK   to book a histogram                                  *
C  S   PYFILL   to fill an entry in a histogram                      *
C  S   PYFACT   to multiply histogram contents by a factor           *
C  S   PYOPER   to perform operations between histograms             *
C  S   PYHIST   to print and reset all histograms                    *
C  S   PYPLOT   to print a single histogram                          *
C  S   PYNULL   to reset contents of a single histogram              *
C  S   PYDUMP   to dump histogram contents onto a file               *
C                                                                    *
C  S   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   STRUCTP  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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(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(I),I=1,100)/
     &  3.141592653589793D0, 6.283185307179586D0,
     &  0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0,  4*0D0,
     1  0.001D0, 0.09D0, 0.01D0, 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/
      DATA (PARU(I),I=101,200)/
     &  0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
     &  0D0, 0D0, 0D0, 0D0,  0D0,
     1  0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0,  0D0, 0D0, 0D0,
     2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
     2 -1.0D0,  1.0D0,  1.0D0,  1.0D0,  0D0,
     3  1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
     4  5.0D0, 1.0D0, 1.0D0,  0D0, 1.0D0, 1.0D0,  0D0, 0D0, 0D0, 0D0,
     5  1.0D0, 0D0, 0D0, 0D0, 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,    2,    2,    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,    2,    0,    0,    1,    0,    0,    0,
     6  40*0,
     &  5,    2,    7,    5,    1,    1,    0,    2,    0,    2,
     1  0,    0,    0,    0,    1,    1,    0,    0,    0,    0,
     2  80*0/
      DATA PARJ/
     &  0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
     &  0.50D0, 0.50D0,   0.6D0,   1.2D0,   0.6D0,
     1  0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
     2  0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
     3  0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,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,1D-4,
     9  0.02D0, 1.0D0, 0.2D0,  0D0,  0D0,  0D0,  0D0, 0D0, 0D0, 0D0,
     &  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
     1  0D0,  0D0,  0D0,  0D0,   0D0,   0D0,  0D0,  0D0,  0D0,  0D0,
     2  1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
     2  2.0D0,  1.0D0, 0.25D0,0.002D0,   0D0,
     3  0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0,  0.2D0,   0D0,
     4  10*0D0,
     5  10*0D0,
     6  10*0D0,
     7  0D0, 200D0, 200D0, .333D0, .05D0, 0D0, 0D0, 0D0, 0D0, -0.693D0, 
     8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,  
     8  1.0D0,  1.0D0, -0.693D0, -1.0D0, 0.387D0, 
     9  1.0D0, -0.08D0, -1.0D0,   1.0D0, 1.0D0,  
     9  5*0D0/  
 
C...PYDAT2, with particle data and flavour treatment parameters.
      DATA (KCHG(I,1),I=   1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,   
     &-3,0,-3,6*0,3,9*0,3,2*0,3,0,-1,12*0,3,2*0,3,5*0,2*6,3,20*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,5*0,6*1,15*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, 211)/0.33D0,0.33D0,0.50D0,1.50D0,    
     &4.80D0,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*110D0,3*210D0,4*0D0,2*200D0,  
     &4*750D0,16*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/      
      DATA (PMAS(I,1),I= 212, 500)/5.40145D0,5.8D0,5.81D0,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.39883D0,16*0D0,2.48009D0,    
     &2.07002D0,0.00237D0,6*0D0,14.54848D0,0D0,16.6708D0,8.42842D0,     
     &4.92026D0,5.75967D0,0.10158D0,0.39162D0,417.4648D0,10*0D0,        
     &0.04104D0,0.0105D0,0.02807D0,0.82101D0,0.64973D0,0.1575D0,4*0D0,  
     &0.88161D0,0.88001D0,19.33905D0,39*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.65171D0,2.65499D0,0.42901D0,0.41917D0,163*0D0/                  
      DATA (PMAS(I,3),I=   1, 500)/5*0D0,13.98835D0,16*0D0,24.8009D0,   
     &20.70015D0,0.02369D0,6*0D0,145.48484D0,0D0,166.70801D0,           
     &84.28416D0,49.20256D0,57.59671D0,1.0158D0,3.91624D0,4174.64797D0, 
     &10*0D0,0.41042D0,0.10504D0,0.28068D0,8.21005D0,6.49728D0,         
     &1.57496D0,4*0D0,8.81606D0,8.80013D0,193.39048D0,39*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.51715D0,26.54994D0,4.29011D0,4.19173D0,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  0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 5*0D0,
     & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
     1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
     2 0.2D0, 0.1D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0,  0D0, 0D0,
     3 60*0D0,
     4 0.2D0,  0.5D0,  8*0D0,
     5 1800*0D0/
      DATA ((VCKM(I,J),J=1,4),I=1,4)/
     &  0.95113D0,  0.04884D0,  0.00003D0,  0.00000D0,
     &  0.04884D0,  0.94940D0,  0.00176D0,  0.00000D0,
     &  0.00003D0,  0.00176D0,  0.99821D0,  0.00000D0,
     &  0.00000D0,  0.00000D0,  0.00000D0,  1.00000D0/
 
C...PYDAT3, with particle decay parameters and data.        
      DATA (MDCY(I,1),I=   1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,   
     &7*1,10*0,6*1,4*0,3*1,19*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,56,66,2*0,76,80,82,  
     &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,416,  
     &496,523,526,527,10*0,536,544,550,558,582,608,4*0,632,639,646,     
     &19*0,658,659,663,16*0,672,674,679,688,0,697,699,701,0,708,716,    
     &722,731,733,735,738,748,754,757,0,768,774,785,791,854,857,865,    
     &926,928,936,969,971,0,975,976,979,981,1017,1018,1026,1062,1063,   
     &1071,1110,1111,1115,1146,1147,1151,1152,1161,0,1163,4*0,1164,3*0, 
     &1167,1170,2*0,1171,1173,1176,2*0,1180,1181,1184,1187,0,1190,1195, 
     &1197,1200,1202,2*0,1206,1207,1208,1284,2*0,1288,1289,1290,1291,   
     &1292,2*0,1296,1297,1299,1300,1302,1306,0,1307,1311,1315,1319,     
     &1323,1327,1331,2*0,1335,1336,1337,1354,1363,2*0,1372,1373,1374,   
     &1375,1376,1385,2*0,1394,1395,1396,1397,1398,1407,1408,2*0,1417,   
     &1426,1435,1444,1453,1462,1471,1480,0,1489,1498,1507,1516,1525,    
     &1534,1543,1552,1561,1570,1571,1572,1573,1574,1579,1582,1584,1589, 
     &1591,1596,1603,1607,1609,1611,1613,1615,1617,1619,1621,1622,1624, 
     &1626,1628,1630,1632,1634,1636,1638,1640,1641,1643,1645,1659,1661, 
     &1663,1667,1669,1671,1673,1675,1677,1679,1681,1683,1685,1696,1710, 
     &1722,1734,1746,1758,1770,1785,1796,1807,1818,1829,1840,1851,1912, 
     &1919,2021,2077,2195,2329,0,2400,2416,2432,2448,2464,2480,2496,0,  
     &2511,0,2526,0,2541,2545,2549,2552,163*0/                          
      DATA (MDCY(I,3),I=   1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,    
     &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,8,6,8,24,26,24, 
     &4*0,2*7,12,19*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,15,6*11,61,7,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,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
     &2*-1, 3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
     &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,    
     &4*-1,6*1,2*-1,3*1,-1,8*1,62*1,6*1,2*-1,3*1,-1,6*1,62*1,3*1,-1,  
     &3*1,-1,1,18*1,8*1,2*-1,2*1,-1,36*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,  
     &3*1,5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,1151*1,2*-1,132*1,2*-1,635*1,  
     &1447*0/                                                           
      DATA (MDME(I,2),I=   1,4000)/43*102,4*0,102,0,6*53,3*102,4*0,102, 
     &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,     
     &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,   
     &8*32,14*0,16*32,7*0,8*32,12*0,62*53,8*32,10*0,62*53,4*32,5*0,     
     &18*53,3*32,0,6*32,3*0,4*32,3*0,4*32,3*0,4*32,3*0,32,8*0,8*32,     
     &14*0,16*32,12*0,8*32,22*0,9*32,3*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,832*53,1459*0/                                                
      DATA (BRAT(I)  ,I=   1, 348)/43*0D0,0.00003D0,0.001765D0,         
     &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,  
     &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,     
     &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,        
     &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,      
     &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,  
     &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,        
     &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,    
     &0.00025D0,35*0D0,0.154075D0,0.119483D0,0.154072D0,0.119346D0,     
     &0.152196D0,3*0D0,0.033549D0,0.066752D0,0.033549D0,0.066752D0,     
     &0.033473D0,0.066752D0,2*0D0,0.321502D0,0.016502D0,2*0D0,          
     &0.016509D0,0.320778D0,2*0D0,0.00001D0,0.000591D0,6*0D0,           
     &2*0.108062D0,0.107983D0,0D0,0.000001D0,0D0,0.000327D0,0.053489D0, 
     &0.852249D0,4*0D0,0.000244D0,0.06883D0,0D0,0.023981D0,0.000879D0,  
     &65*0D0,0.145869D0,0.113303D0,0.145869D0,0.113298D0,0.14581D0,     
     &0.049013D0,2*0D0,0.032007D0,0.063606D0,0.032007D0,0.063606D0,     
     &0.032004D0,0.063606D0,8*0D0,0.251276D0,0.012903D0,0.000006D0,0D0, 
     &0.012903D0,0.250816D0,0.00038D0,0D0,0.000008D0,0.000465D0,        
     &0.215459D0,5*0D0,2*0.085262D0,0.08526D0,7*0D0,0.000046D0,         
     &0.000754D0,5*0D0,0.000074D0,0D0,0.000439D0,0.000015D0,0.000061D0/ 
      DATA (BRAT(I)  ,I= 349, 642)/0.306171D0,0.68864D0,0D0,0.003799D0, 
     &66*0D0,0.000079D0,0.001292D0,5*0D0,0.000126D0,0D0,0.002256D0,     
     &0.00001D0,0.000002D0,2*0D0,0.996233D0,63*0D0,0.000013D0,          
     &0.067484D0,2*0D0,0.00001D0,0.002701D0,0D0,0.929792D0,18*0D0,      
     &0.452899D0,0D0,0.547101D0,1D0,2*0.215134D0,0.215133D0,0.214738D0, 
     &2*0D0,2*0.06993D0,0D0,0.000225D0,0.036777D0,0.596654D0,2*0D0,     
     &0.000177D0,0.050055D0,0.316112D0,0.041762D0,0.90916D0,2*0D0,      
     &0.000173D0,0.048905D0,0.000328D0,0.053776D0,0.872444D0,2*0D0,     
     &0.000259D0,0.073192D0,0D0,0.153373D0,2*0.342801D0,0D0,0.086867D0, 
     &0.03128D0,0.001598D0,0.000768D0,0.004789D0,0.006911D0,0.004789D0, 
     &0.006911D0,0.004789D0,3*0D0,0.003077D0,0.00103D0,0.003077D0,      
     &0.00103D0,0.003077D0,0.00103D0,2*0D0,0.138845D0,0.474102D0,       
     &0.176299D0,0D0,0.109767D0,0.008161D0,0.028584D0,0.001468D0,2*0D0, 
     &0.001468D0,0.02853D0,0.000007D0,0D0,0.000001D0,0.000053D0,        
     &0.003735D0,5*0D0,2*0.009661D0,0.00966D0,0D0,0.163019D0,           
     &0.004003D0,0.45294D0,0.008334D0,2*0.038042D0,0.001999D0,0D0,      
     &0.017733D0,0.045908D0,0.017733D0,0.045908D0,0.017733D0,3*0D0,     
     &0.038354D0,0.011181D0,0.038354D0,0.011181D0,0.038354D0,           
     &0.011181D0,2*0D0,0.090264D0,2*0.001805D0,0.090264D0,0.001805D0,   
     &0.81225D0,0.001806D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0/ 
      DATA (BRAT(I)  ,I= 643, 803)/0.001808D0,0.81372D0,0D0,0.325914D0, 
     &0.016735D0,0.000009D0,0.016736D0,0.32532D0,0.000554D0,0.00001D0,  
     &0.000603D0,0.314118D0,3*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,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/      
      DATA (BRAT(I)  ,I= 804, 977)/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,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/     
      DATA (BRAT(I)  ,I= 978,1136)/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,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/   
      DATA (BRAT(I)  ,I=1137,1341)/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,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/    
      DATA (BRAT(I)  ,I=1342,1522)/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,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/      
      DATA (BRAT(I)  ,I=1523,2548)/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,0.008D0,0.024D0,0.425D0,0.02D0,0.185D0,0.088D0,   
     &0.043D0,0.067D0,0.066D0,831*0D0,0.85422D0,0.005292D0,0.044039D0,  
     &0.096449D0,0.853165D0,0.021144D0,0.029361D0,0.096329D0/           
      DATA (BRAT(I)  ,I=2549,4000)/0.294414D0,0.109437D0,0.596149D0,    
     &0.389861D0,0.610139D0,1447*0D0/                                   
      DATA (KFDP(I,1),I=   1, 374)/21,22,23,4*-24,25,21,22,23,4*24,25,  
     &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,    
     &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22, 
     &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,   
     &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25, 
     &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,  
     &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,  
     &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,        
     &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,        
     &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,        
     &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,         
     &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,        
     &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,        
     &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,        
     &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,         
     &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,  
     &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,   
     &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,36,  
     &1000022,2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,        
     &1000001,2000001,1000001,-1000001,1000002,2000002,1000002/         
      DATA (KFDP(I,1),I= 375, 587)/-1000002,1000003,2000003,1000003,    
     &-1000003,1000004,2000004,1000004,-1000004,1000005,2000005,        
     &1000005,-1000005,1000006,2000006,1000006,-1000006,1000011,        
     &2000011,1000011,-1000011,1000012,2000012,1000012,-1000012,        
     &1000013,2000013,1000013,-1000013,1000014,2000014,1000014,         
     &-1000014,1000015,2000015,1000015,-1000015,1000016,2000016,        
     &1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,    
     &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,3,4,5,6, 
     &11,13,15,21,2*4,24,-11,-13,-15,3,4,5,6,11,13,15,21,2*24,2*52,     
     &2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*52,24/   
      DATA (KFDP(I,1),I= 588, 979)/4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17, 
     &22,23,22,23,24,52,24,52,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,  
     &3*-11,2*-13,-15,24,3*-11,2*-13,-15,63,3*-1,3*-3,3*-5,-11,-13,-15, 
     &82,-11,-13,2*2,-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,   
     &11,213,-213,221,223,321,130,310,111,331,111,211,-12,12,-14,14,    
     &211,111,22,-13,-11,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/   
      DATA (KFDP(I,1),I= 980,1419)/82,6*12,6*14,2*16,3*-411,3*-413,     
     &2*-411,2*-413,2*441,2*443,2*20443,2*2,2*4,2,4,511,521,511,523,    
     &513,523,513,521,511,6*12,6*14,2*16,3*-421,3*-423,2*-421,2*-423,   
     &2*441,2*443,2*20443,2*2,2*4,2,4,521,511,521,513,523,513,523,511,  
     &521,6*12,6*14,2*16,3*-431,3*-433,2*-431,2*-433,3*441,3*443,       
     &3*20443,2*2,2*4,2,4,531,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/     
      DATA (KFDP(I,1),I=1420,1739)/2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,    
     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,  
     &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,   
     &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,  
     &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,     
     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,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/        
      DATA (KFDP(I,1),I=1740,1907)/1000035,1000004,2000004,1000004,     
     &2000004,1000021,1000039,1000024,1000037,1000022,1000023,1000025,  
     &1000035,1000003,2000003,1000003,2000003,1000021,1000039,-1000024, 
     &-1000037,1000022,1000023,1000025,1000035,1000006,2000006,1000006, 
     &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025,  
     &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016,  
     &-1000015,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/      
      DATA (KFDP(I,1),I=1908,2126)/1000037,-1000037,1000037,-1000037,   
     &5*1000039,4,1,5*1000039,16*1000022,1000024,-1000024,1000024,      
     &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,      
     &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,       
     &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,      
     &1000024,-1000024,1000037,-1000037,1000001,-1000001,2000001,       
     &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003,      
     &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005,       
     &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006,      
     &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012,       
     &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014,      
     &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016,       
     &-1000016,2000016,-2000016,5*1000021,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/       
      DATA (KFDP(I,1),I=2127,2315)/-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,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/      
      DATA (KFDP(I,1),I=2316,2516)/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,        
     &-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/        
      DATA (KFDP(I,1),I=2517,4000)/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,1447*0/                        
      DATA (KFDP(I,2),I=   1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, 
     &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,  
     &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14, 
     &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,     
     &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,     
     &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211, 
     &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, 
     &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,  
     &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,  
     &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,   
     &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,    
     &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,     
     &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,          
     &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,          
     &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,          
     &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,          
     &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,          
     &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, 
     &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8, 
     &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/   
      DATA (KFDP(I,2),I= 340, 526)/-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= 527, 931)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-3,-4, 
     &-5,-6,-11,-13,-15,21,-3,-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21, 
     &-24,-52,-24,-52,51,53,51,53,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,  
     &-14,-15,-16,-17,-18,23,51,23,51,22,53,2,4,6,8,2,4,6,8,2,4,6,8,2,  
     &4,6,8,12,14,16,18,2*51,2*53,-52,2*-24,-52,-1,-2,-3,-4,-5,-6,-7,   
     &-8,-11,-12,-13,-14,-15,-16,-17,-18,-11,-13,-15,-13,2*-15,24,-11,  
     &-13,-15,-13,2*-15,63,2,4,6,2,4,6,2,4,6,64,65,66,-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/ 
      DATA (KFDP(I,2),I= 932,1317)/-211,211,-211,211,16,5*12,5*14,      
     &3*211,3*213,211,2*111,2*113,2*-311,2*-313,-2112,3*321,323,2*-1,   
     &22,111,321,311,321,311,-82,-11,-13,-82,22,-82,6*-11,6*-13,2*-15,  
     &211,213,20213,211,213,20213,431,433,431,433,311,313,311,313,311,  
     &313,-1,-4,-3,-4,-1,-3,22,-211,111,-211,111,-211,211,-211,211,     
     &6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,433,    
     &321,323,321,323,321,323,-1,-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/  
      DATA (KFDP(I,2),I=1318,1756)/-3,12,14,-1,-3,12,14,-1,-3,12,14,-1, 
     &-3,12,14,-1,-3,2*-211,11,13,15,-211,-213,-20213,-431,-433,3*3122, 
     &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,2*111,      
     &2*211,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,4*22,11,13,15,1,  
     &4,3,4,1,3,22,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,  
     &1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1, 
     &4,3,4,1,3,11,13,15,1,4,3,4,1,3,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/  
      DATA (KFDP(I,2),I=1757,2220)/4,5,2*6,4*5,2*-24,2*-37,5,6,2*5,4*6, 
     &2*24,2*37,6,4,-15,16,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,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,-1,-3,22,23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,  
     &35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13, 
     &15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,  
     &4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,    
     &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,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/  
      DATA (KFDP(I,2),I=2221,4000)/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,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,1447*0/                                                        
      DATA (KFDP(I,3),I=   1,1134)/81*0,14,6*0,2*16,2*0,6*111,310,130,  
     &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,    
     &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,   
     &407*0,-5,112*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/  
      DATA (KFDP(I,3),I=1135,2233)/533,3,2,3,2,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,76*0,2*5,91*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,5*0,11,12,7*0,-11,-13,-15,-12,-14,  
     &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, 
     &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,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/    
      DATA (KFDP(I,3),I=2234,4000)/-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,-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,1601*0/                                           
      DATA (KFDP(I,4),I=   1,4000)/94*0,4*111,6*0,111,2*0,-211,0,-211,  
     &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,     
     &6*111,310,2*130,520*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,2398*0/                                      
      DATA (KFDP(I,5),I=   1,4000)/96*0,2*111,17*0,111,7*0,2*111,0,     
     &3*111,0,111,715*0,-211,2*111,-211,111,-211,111,65*0,111,-211,     
     &3*111,-211,111,3075*0/                                            
       
C...PYDAT4, with particle names (character strings). 
      DATA (CHAF(I,1),I=   1, 185)/'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',4*' ','H_L++','H_R++',       
     &'W_R+','nu_Re','nu_Rmu','nu_Rtau',14*' ','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'/       
      DATA (CHAF(I,1),I= 186, 315)/'Lambda_c+','Xi_c0','cu_0','cu_1',   
     &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',   
     &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',          
     &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++',       
     &'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'/  
      DATA (CHAF(I,1),I= 316, 500)/'~chi_20','~chi_1+','~chi_30',       
     &'~chi_40','~chi_2+','~gravitino','~d_R','~u_R','~s_R','~c_R',     
     &'~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR','~tau_2-',      
     &'~nu_tauR','d*','u*','e*-','nu*_e0',163*' '/                      
      DATA (CHAF(I,2),I=   1, 198)/'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-',5*' ','H_L--','H_R--','W_R-','nu_Rebar','nu_Rmubar',  
     &'nu_Rtaubar',15*' ','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'/          
      DATA (CHAF(I,2),I= 199, 308)/'Xi''_cbar-','Xi*_cbar-',            
     &'Omega_cbar0','Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-',  
     &'Xi_ccbar--','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+'/        
      DATA (CHAF(I,2),I= 309, 500)/'~nu_eLbar','~mu_L+','~nu_muLbar',   
     &'~tau_1+','~nu_tauLbar',3*' ','~chi_1-',2*' ','~chi_2-',' ',      
     &'~d_Rbar','~u_Rbar','~s_Rbar','~c_Rbar','~b_2bar','~t_2bar',      
     &'~e_R+','~nu_eRbar','~mu_R+','~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,  -40D0,   40D0,
     1  -40D0,   40D0,  -40D0,   40D0,  -40D0,
     1   40D0, -1.0D0,  1.0D0, -1.0D0,  1.0D0,
     2  0.0D0,  1.0D0,  0.0D0,  1.0D0, -1.0D0,
     2  1.0D0, -1.0D0,  1.0D0,    0D0,    0D0,
     3  2.0D0, -1.0D0,    0D0,    0D0,  0.0D0,
     3 -1.0D0,  0.0D0, -1.0D0,  4.0D0, -1.0D0,
     4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
     4 -1.0D0, 12.0D0, -1.0D0,    0D0,    0D0,
     5  0.0D0, -1.0D0,  0.0D0, -1.0D0,  0.0D0,
     5 -1.0D0,    0D0,    0D0,    0D0,    0D0,
     6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0,    0D0,
     6   -1D0,    0D0,   -1D0,    0D0,   -1D0,
     7    0D0,   -1D0, 0.0001D0, 0.99D0, 0.0001D0,
     7 0.99D0,    2D0,   -1D0,    0D0,    0D0,
     8  120*0D0/
 
C...Default values for main switches and parameters. Reset information.
      DATA (MSTP(I),I=1,100)/
     &  3,    1,    2,    0,    0,    0,    0,    0,    0,    0,
     1  1,    0,    1,   30,    0,    1,    4,    3,    4,    3,
     2  1,    0,    1,    0,    0,    0,    0,    0,    0,    1,
     3  1,    8,    0,    1,    0,    2,    1,    5,    2,    0,
     4  1,    1,    3,    7,    3,    1,    1,    0,    1,    0,
     5  4,    1,    3,    1,    5,    1,    1,    5,    1,    7,
     6  1,    3,    2,    2,    1,    5,    2,    1,    0,    0,
     7  1,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     8  1,    1,  100,    0,    0,    2,    0,    0,    0,    0,
     9  1,    3,    1,    3,    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,  152, 2000,   08,   17,    0,    0,    0,    0,    0,
     9  0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
      DATA (PARP(I),I=1,100)/
     &  0.25D0,  10D0, 8*0D0,
     1  0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
     2  10*0D0,
     3  1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0,
     4  0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0,
     5  10*0D0,
     6  0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0,
     7  4.0D0, 0.25D0, 8*0D0,
     8  1.90D0, 2.10D0, 0.5D0, 0.2D0, 0.33D0, 
     8  0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0,
     9  1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
      DATA (PARP(I),I=101,200)/
     &  0.5D0, 0.28D0,  1.0D0, 0.8D0, 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, 8*0D0, 0D0,
     4  0.33333D0, 82D0, 1.33333D0, 4D0, 1D0, 
     4  1D0,  .0182D0, 1D0, 0D0, 1.33333D0,
     5  0D0,   0D0,   0D0,   0D0, 6*0D0,
     6  2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
     7  0D0,   0D0,   0D0,  1.0D0, 6*0D0,
     8  0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
     8  0.3D0, 0.64D0,    
     9  0.64D0, 5.0D0, 8*0D0/
      DATA MSTI/200*0/
      DATA PARI/200*0D0/
      DATA MINT/400*0/
      DATA VINT/400*0D0/
 
C...Constants for the generation of the various processes.
      DATA (ISET(I),I=1,100)/
     &  1,    1,    1,   -1,    3,   -1,   -1,    3,   -2,    2,
     1  2,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
     2 -1,    2,    2,    2,    2,    2,   -1,    2,    2,    2,
     3  2,    2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,
     4 -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     5 -1,   -1,    2,    2,   -1,   -1,   -1,    2,   -1,   -1,
     6 -1,   -1,   -1,   -1,   -1,   -1,   -1,    2,    2,    2,
     7  4,    4,    4,   -1,   -1,    4,    4,   -1,   -1,    2,
     8  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
     9  0,    0,    0,    0,    0,    9,   -2,   -2,    8,   -2/
      DATA (ISET(I),I=101,200)/
     & -1,    1,    1,    1,    1,    2,    2,    2,   -2,    2,
     1  2,    2,    2,    2,    2,   -1,   -1,   -1,   -2,   -2,
     2  5,    5,    5,    5,   -2,   -2,   -2,   -2,   -2,   -2,
     3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     4  1,    1,    1,    1,    1,    1,    1,    1,    1,   -2,
     5  1,    1,    1,   -2,   -2,    1,    1,    1,   -2,   -2,
     6  2,    2,    2,    2,    2,    2,    2,    2,    2,   -2,
     7  2,    2,    5,    5,   -2,    2,    2,    5,    5,   -2,
     8  5,    5,   -2,   -2,   -2,    5,    5,   -2,   -2,   -2,
     9  1,    1,    1,    2,    2,   -2,   -2,   -2,   -2,   -2/
      DATA (ISET(I),I=201,300)/
     &  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     1  2,    2,    2,    2,   -2,    2,    2,    2,    2,    2,
     2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     3  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     4  2,    2,    2,    2,   -1,    2,    2,    2,    2,    2,
     5  2,    2,    2,    2,   -1,    2,   -1,    2,    2,   -2,
     6  2,    2,    2,    2,    2,   -1,   -1,   -1,   -1,   -1,
     7  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     8  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     9  2,    2,    2,    2,    2,    2,    2,    2,    2,    2/
      DATA (ISET(I),I=301,500)/
     &  2,   39*-2,
     4  1,    1,    2,    2,    2,    2,    2,    2,    2,    2,
     5  5,    5,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
     6  2,    2,    2,    2,    2,    2,    2,    2,   -1,    2,
     7  2,    2,    2,    2,    2,    2,    2,   -1,   -1,   -1,
     8  120*-2/
      DATA ((KFPR(I,J),J=1,2),I=1,50)/
     &  23,    0,   24,    0,   25,    0,   24,    0,   25,    0,
     &  24,    0,   23,    0,   25,    0,    0,    0,    0,    0,
     1   0,    0,    0,    0,   21,   21,   21,   22,   21,   23,
     1  21,   24,   21,   25,   22,   22,   22,   23,   22,   24,
     2  22,   25,   23,   23,   23,   24,   23,   25,   24,   24,
     2  24,   25,   25,   25,    0,   21,    0,   22,    0,   23,
     3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
     3   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
     4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23,
     4   0,   24,    0,   25,    0,   21,    0,   22,    0,   23/
      DATA ((KFPR(I,J),J=1,2),I=51,100)/
     5   0,   24,    0,   25,    0,    0,    0,    0,    0,    0,
     5   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     6   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     6   0,    0,    0,    0,   21,   21,   24,   24,   23,   24,
     7  23,   23,   24,   24,   23,   24,   23,   25,   22,   22,
     7  23,   23,   24,   24,   24,   25,   25,   25,    0,  211,
     8   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     8 443,   21,10441,   21,20443,   21,  445,   21,    0,    0,
     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
      DATA ((KFPR(I,J),J=1,2),I=101,150)/
     &  23,    0,   25,    0,   25,    0,10441,    0,  445,    0,
     & 443,   22,  443,   21,  443,   22,    0,    0,   22,   25,
     1  21,   25,    0,   25,   21,   25,   22,   22,   21,   22,
     1  22,   23,   23,   23,   24,   24,    0,    0,    0,    0,
     2  25,    6,   25,    6,   25,    0,   25,    0,    0,    0,
     2   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     3   0,   21,    0,   21,    0,   22,    0,   22,    0,    0,
     3   0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
     4  32,    0,   34,    0,   37,    0,   40,    0,   39,    0,
     4 4000011, 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, 4000011,    0,    0,
     7  23,   35,   24,   35,   35,    0,   35,    0,    0,    0,
     7  23,   36,   24,   36,   36,    0,   36,    0,    0,    0,
     8  35,    6,   35,    6,    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,   11,    0,
     9   0,    0,    0,    0,    0,    0,    0,    0,    0,    0/
      DATA ((KFPR(I,J),J=1,2),I=201,250)/
     &  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,
     4  1000021,   1000024,   1000021,   1000037,   1000021,
     4  1000021,   1000021,   1000021,         0,         0,
     4  1000002,   1000022,   2000002,   1000022,   1000002,
     4  1000023,   2000002,   1000023,   1000002,   1000025/
      DATA ((KFPR(I,J),J=1,2),I=251,300)/
     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,
     8  1000005,   1000002,   2000005,   2000002,   1000005,
     8  2000002,   1000005,   1000002,   2000005,   2000002,
     8  1000005,   2000002,   1000005,   1000005,   2000005,
     8  2000005,   1000005,   1000005,   2000005,   2000005,
     9  1000005,   1000005,   2000005,   2000005,   1000005,
     9  2000005,   1000005,   1000021,   2000005,   1000021,
     9  1000005,   2000005,        37,        25,        37,
     9       35,        36,        25,        36,        35/
      DATA ((KFPR(I,J),J=1,2),I=301,500)/
     &       37,        37,      78*0,
     4       61,         0,        62,         0,        61,
     4       11,        62,        11,        61,        13,
     4       62,        13,        61,        15,        62,  
     4       15,        61,        61,        62,        62,
     5       61,         0,        62,         0,         0,
     5        0,         0,         0,         0,         0,
     5        0,         0,         0,         0,         0,
     5        0,         0,         0,         0,         0,
     6       24,        24,        24,        52,        52,        
     6       52,        22,        51,        22,        53,        
     6       23,        51,        23,        53,        24,        
     6       52,         0,         0,        24,        23,        
     7       24,        51,        52,        23,        52,        
     7       51,        22,        52,        23,        52,        
     7       24,        51,        24,        53,         0,         
     7        0,         0,         0,         0,         0,
     8    240*0/      
      DATA COEF/10000*0D0/
      DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
     &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
     &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
     &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
     &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
     &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
     &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
     &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
     &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
     &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
     &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
 
C...Treatment of resonances.
      DATA (MWID(I)  ,I=   1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,7*1,   
     &10*0,6*1,4*0,3*1,238*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'q + gamma* -> q             ',  '                            '/
      DATA (PROC(I),I=101,120)/
     &'g + g -> gamma*/Z0          ',  'g + g -> h0                 ',
     &'gamma + gamma -> h0         ',  'g + g -> chi_0c             ',
     &'g + g -> chi_2c             ',  'g + g -> J/Psi + gamma      ',
     &'gamma + g -> J/Psi + g      ',  'gamma+gamma -> J/Psi + gamma',
     &'                            ',  'f + fbar -> gamma + h0      ',
     1'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'f + gamma*_T -> f + g       ',  'f + gamma*_L -> f + g       ',
     3'f + gamma*_T -> f + gamma   ',  'f + gamma*_L -> f + gamma   ',
     3'g + gamma*_T -> f + fbar    ',  'g + gamma*_L -> f + fbar    ',
     3'gamma*_T+gamma*_T -> f+fbar ',  'gamma*_T+gamma*_L -> f+fbar ',
     3'gamma*_L+gamma*_T -> f+fbar ',  'gamma*_L+gamma*_L -> f+fbar '/
      DATA (PROC(I),I=141,160)/
     4'f + fbar -> gamma*/Z0/Z''0   ', 'f + fbar'' -> W''+/-          ',
     4'f + fbar'' -> H+/-           ', 'f + fbar'' -> R              ',
     4'q + l -> LQ                 ',  'e + gamma -> e*             ',
     4'd + g -> d*                 ',  'u + g -> u*                 ',
     4'g + g -> eta_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'q + qbar -> e + e*          ',  '                            ',
     7'f + fbar -> Z0 + H0         ', 'f + fbar'' -> W+/- + H0      ',
     7'f + f'' -> f + f'' + H0       ',
     7'f + f'' -> f" + f"'' + H0     ',
     7'                            ',  'f + fbar -> Z0 + A0         ',
     7'f + fbar'' -> W+/- + A0      ',
     7'f + f'' -> f + f'' + A0       ',
     7'f + f'' -> f" + f"'' + A0     ',
     7'                            '/
      DATA (PROC(I),I=181,200)/
     8'g + g -> Q + Qbar + H0      ',  'q + qbar -> Q + Qbar + H0   ',
     8'                            ',  '                            ',
     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'' (ETC)  ',
     9'f+fbar'' -> f"+fbar"'' (ETC)','                          ',
     9'                            ',  '                            ',
     9'                            ',  '                            '/
      DATA (PROC(I),I=201,220)/
     &'f + fbar -> ~e_L + ~e_Lbar  ',  'f + fbar -> ~e_R + ~e_Rbar  ',
     &'f + fbar -> ~e_R + ~e_Lbar  ',  'f + fbar -> ~mu_L + ~mu_Lbar',
     &'f + fbar -> ~mu_R + ~mu_Rbar',  'f + fbar -> ~mu_L + ~mu_Rbar',
     &'f+fbar -> ~tau_1 + ~tau_1bar',  'f+fbar -> ~tau_2 + ~tau_2bar',
     &'f+fbar -> ~tau_1 + ~tau_2bar',  'q + qbar'' -> ~l_L + ~nulbar ',
     1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
     1'f + fbar -> ~nul + ~nulbar  ',  'f+fbar -> ~nutau + ~nutaubar',
     1'                            ',  'f + fbar -> ~chi1 + ~chi1   ',
     1'f + fbar -> ~chi2 + ~chi2   ',  'f + fbar -> ~chi3 + ~chi3   ',
     1'f + fbar -> ~chi4 + ~chi4   ',  'f + fbar -> ~chi1 + ~chi2   '/
      DATA (PROC(I),I=221,240)/
     2'f + fbar -> ~chi1 + ~chi3   ',  'f + fbar -> ~chi1 + ~chi4   ',
     2'f + fbar -> ~chi2 + ~chi3   ',  'f + fbar -> ~chi2 + ~chi4   ',
     2'f + fbar -> ~chi3 + ~chi4   ',  'f+fbar -> ~chi+-1 + ~chi-+1 ',
     2'f+fbar -> ~chi+-2 + ~chi-+2 ',  'f+fbar -> ~chi+-1 + ~chi-+2 ',
     2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
     3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
     3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
     3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
     3'q + qbar -> ~chi1 + ~g      ',  'q + qbar -> ~chi2 + ~g      ',
     3'q + qbar -> ~chi3 + ~g      ',  'q + qbar -> ~chi4 + ~g      '/
      DATA (PROC(I),I=241,260)/
     4'q + qbar'' -> ~chi+-1 + ~g   ', 'q + qbar'' -> ~chi+-2 + ~g  ',
     4'q + qbar -> ~g + ~g         ',  'g + g -> ~g + ~g            ',
     4'                            ',  'qj + g -> ~qj_L + ~chi1     ',
     4'qj + g -> ~qj_R + ~chi1     ',  'qj + g -> ~qj_L + ~chi2     ',
     4'qj + g -> ~qj_R + ~chi2     ',  'qj + g -> ~qj_L + ~chi3     ',
     5'qj + g -> ~qj_R + ~chi3     ',  'qj + g -> ~qj_L + ~chi4     ',
     5'qj + g -> ~qj_R + ~chi4     ',  'qj + g -> ~qk_L + ~chi+-1   ',
     5'qj + g -> ~qk_R + ~chi+-1   ',  'qj + g -> ~qk_L + ~chi+-2   ',
     5'qj + g -> ~qk_R + ~chi+-2   ',  'qj + g -> ~qj_L + ~g        ',
     5'qj + g -> ~qj_R + ~g        ',  '                            '/
      DATA (PROC(I),I=261,300)/
     6'f + fbar -> ~t_1 + ~t_1bar  ',  'f + fbar -> ~t_2 + ~t_2bar  ',
     6'f + fbar -> ~t_1 + ~t_2bar  ',  'g + g -> ~t_1 + ~t_1bar     ',
     6'g + g -> ~t_2 + ~t_2bar     ',  '                            ',
     6'                            ',  '                            ',
     6'                            ',  '                            ',
     7'qi + qj -> ~qi_L + ~qj_L    ',  'qi + qj -> ~qi_R + ~qj_R    ',
     7'qi + qj -> ~qi_L + ~qj_R    ',  'qi+qjbar -> ~qi_L + ~qj_Lbar',
     7'qi+qjbar -> ~qi_R + ~qj_Rbar',  'qi+qjbar -> ~qi_L + ~qj_Rbar',
     7'f + fbar -> ~qi_L + ~qi_Lbar',  'f + fbar -> ~qi_R + ~qi_Rbar',
     7'g + g -> ~qi_L + ~qi_Lbar   ',  'g + g -> ~qi_R + ~qi_Rbar   ',
     8'b + qj -> ~b_1 + ~qj_L      ',  'b + qj -> ~b_2 + ~qj_R      ',
     8'b + qj -> ~b_1 + ~qj_R      ',  'b + qjbar -> ~b_1 + ~qj_Lbar',
     8'b + qjbar -> ~b_2 + ~qj_Rbar',  'b + qjbar -> ~b_1 + ~qj_Rbar',
     8'f + fbar -> ~b_1 + ~b_1bar  ',  'f + fbar -> ~b_2 + ~b_2bar  ',
     8'g + g -> ~b_1 + ~b_1bar     ',  'g + g -> ~b_2 + ~b_2bar     ',
     9'b + b -> ~b_1 + ~b_1        ',  'b + b -> ~b_2 + ~b_2        ',
     9'b + b -> ~b_1 + ~b_2        ',  'b + g -> ~b_1 + ~g          ',
     9'b + g -> ~b_2 + ~g          ',  'b + bbar -> ~b_1 + ~b_2bar  ',
     9'f + fbar'' -> H+/- + h0     ',  'f + fbar -> H+/- + H0       ',
     9'f + fbar -> A0 + h0         ',  'f + fbar -> A0 + H0         '/
      DATA (PROC(I),I=301,340)/
     &'f + fbar -> H+ + H-         ', 39*'                          '/
      DATA (PROC(I),I=341,500)/
     4'l + l -> H_L++/--           ',  'l + l -> H_R++/--           ',
     4'l + gamma -> H_L++/-- e-/+  ',  'l + gamma -> H_R++/-- e-/+  ',
     4'l + gamma -> H_L++/-- mu-/+ ',  'l + gamma -> H_R++/-- mu-/+ ',
     4'l + gamma -> H_L++/-- tau-/+',  'l + gamma -> H_R++/-- tau-/+',
     4'f + fbar -> H_L++ + H_L--   ',  'f + fbar -> H_R++ + H_R--   ',
     5'f + f -> f'' + f'' + H_L++/-- ',  
     5'f + f -> f'' + f'' + H_R++/-- ', 7*'                         ',
     6'                            ',  'f + fbar -> W_L+ W_L-       ',
     6'f + fbar -> W_L+/- pi_T-/+  ',  'f + fbar -> pi_T+ pi_T-     ',
     6'f + fbar -> gamma pi_T0     ',  'f + fbar -> gamma pi_T0''    ',
     6'f + fbar -> Z0 pi_T0        ',  'f + fbar -> Z0 pi_T0''       ',
     6'f + fbar -> W+/- pi_T-/+    ',  '                            ',
     7'f + fbar'' -> W_L+/- Z_L0    ', 'f + fbar'' -> W_L+/- pi_T0   ',
     7'f + fbar'' -> pi_T+/- Z_L0   ', 'f + fbar'' -> pi_T+/- pi_T0  ',
     7'f + fbar'' -> gamma pi_T+/-  ', 'f + fbar'' -> Z0 pi_T+/-     ',
     7'f + fbar'' -> W+/- pi_T0     ',  
     7'f + fbar'' -> W+/- pi_T0''    ',
     7'                            ','                              ',
     8 121*'                      '/    
 
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,0D0,24D17,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)
      IMPLICIT INTEGER(I-N)
      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.10D0)
     &    MERR=MERR+1
          EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
          IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
          IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
        ELSE
          DO 160 J=1,4
            IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
  160     CONTINUE
          IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
        ENDIF
        IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
     &  (PFIN(J),J=1,4),PFIN(6)
 
C...Check that all KF codes are known ones, and that partons/particles
C...satisfy energy-momentum-mass relation. Store particle statistics.
        DO 170 I=1,N
          IF(K(I,1).GT.20) GOTO 170
          IF(PYCOMP(K(I,2)).EQ.0) THEN
            WRITE(MSTU(11),5100) I
            MERR=MERR+1
          ENDIF
          PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
          IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
     &    THEN
            WRITE(MSTU(11),5200) I
            MERR=MERR+1
          ENDIF
  170   CONTINUE
        IF(MTEST.GE.1) CALL PYTABU(21)
 
C...List all erroneous events and some normal ones.
        IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
          IF(MERR.GE.1) WRITE(MSTU(11),6400)
          CALL PYLIST(2)
        ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
          CALL PYLIST(1)
        ENDIF
 
C...Stop execution if too many errors.
        IF(MERR.NE.0) NERR=NERR+1
        IF(NERR.GE.10) THEN
          WRITE(MSTU(11),6300)
          CALL PYLIST(1)
          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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(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*12,CHBEAM*12,CHTARG*12,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..
      DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
     &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
     &NFIN/20*4/
      DATA CHLH/'lepton','hadron'/
 
C...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.20) 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
      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
      ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=3
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
      ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=2
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
      ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
        IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
     &  (IABS(MINT(11)).GE.28.OR.IABS(MINT(12)).GE.28)) MINT(121)=4
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
      ENDIF
      MINT(123)=MSTP(14)
      IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
     &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
      IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
        IF(MSTP(14).EQ.11) MINT(123)=0
        IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
        IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
        IF(MSTP(14).EQ.15) MINT(123)=2
        IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
        IF(MSTP(14).EQ.19) MINT(123)=3
      ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
        IF(MSTP(14).EQ.21) MINT(123)=0
        IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
        IF(MSTP(14).EQ.24) MINT(123)=1
      ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
        IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
        IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
      ENDIF
 
C...Set up kinematics of process.
      CALL PYINKI(0)
 
C...Set up kinematics for photons inside leptons.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
 
C...Precalculate flavour selection weights.
      CALL PYKFIN
 
C...Loop over gamma-p or gamma-gamma alternatives.
      CKIN3=CKIN(3)
      MSAV48=0  
      DO 160 IGA=1,MINT(121)
        CKIN(3)=CKIN3 
        MINT(122)=IGA
 
C...Select partonic subprocesses to be included in the simulation.
        CALL PYINPR
        MINT(101)=1
        MINT(102)=1
        MINT(103)=MINT(11)
        MINT(104)=MINT(12)
  
C...Count number of subprocesses on.
        MINT(48)=0
        DO 130 ISUB=1,500
          IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
     &    MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
            MSUB(ISUB)=0 
          ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
     &    MSUB(ISUB).EQ.1) THEN
            WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
            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(121).EQ.1.AND.MINT(48).EQ.0) THEN
          WRITE(MSTU(11),5500)
          STOP
        ENDIF
        MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
        MSAV48=MSAV48+MINT(48)
 
C...Reset variables for cross-section calculation.
        DO 150 I=0,500
          DO 140 J=1,3
            NGEN(I,J)=0
            XSEC(I,J)=0D0
  140     CONTINUE
  150   CONTINUE

C...Find parametrized total cross-sections.
        CALL PYXTOT
        VINT(318)=VINT(317)
 
C...Maxima of differential cross-sections.
        IF(MSTP(121).LE.1) CALL PYMAXI
 
C...Initialize possibility of pileup events.
        IF(MINT(121).GT.1) MSTP(131)=0
        IF(MSTP(131).NE.0) CALL PYPILE(1)
 
C...Initialize multiple interactions with variable impact parameter.
        IF(MINT(50).EQ.1.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.
      IF(MSAV48.EQ.0) THEN
        WRITE(MSTU(11),5500)
        STOP
      ENDIF
  170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
 
C...Formats for initialization information.
 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
     &'routines',1X,17('*'))
 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
     &'-',A6,' interactions.'/1X,'Execution stopped!')
 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
     &1X,'Execution stopped!')
 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
     &1X,'Execution stopped!')
 5500 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
     &22('*'))
 
      RETURN
      END
 
C*********************************************************************
 
C...PYEVNT
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines.
 
      SUBROUTINE PYEVNT
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
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).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
          MINT31=MINT(31)
  110     MINT(31)=MINT31
          MINT(51)=0
          CALL PYSCAT
          IF(MINT(51).EQ.1) GOTO 100
          IPU1=MINT(84)+1
          IPU2=MINT(84)+2
          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
 
         ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
          CALL PYDIFF

        ELSE
C...DIS scattering (photon flux external).
          CALL PYDISG
          IF(MINT(51).EQ.1) GOTO 100
        ENDIF
 
C...Check that no odd resonance left undecayed.
        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...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
 
C...Recalculate energies from momenta and masses (if desired).
        IF(MSTP(113).GE.1) THEN
          DO 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)
      IMPLICIT INTEGER(I-N)
      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,
     &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*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 PROGG9/
     &'direct * direct             ','direct * VMD                ',
     &'direct * anomalous          ','VMD * direct                ',
     &'VMD * VMD                   ','VMD * anomalous             ',
     &'anomalous * direct          ','anomalous * VMD             ',
     &'anomalous * anomalous       ','DIS * VMD                   ',
     &'DIS * anomalous             ','VMD * DIS                   ',
     &'anomalous * DIS             '/
      DATA PROGG4/
     &'direct * direct             ','direct * resolved           ',
     &'resolved * direct           ','resolved * resolved         '/
      DATA PROGG2/
     &'direct * hadron             ','resolved * hadron           '/
      DATA PROGP4/
     &'VMD * hadron                ','direct * hadron             ',
     &'anomalous * hadron          ','DIS * hadron                '/
      DATA STATE/'----','off ','on  ','on/+','on/-','on/1','on/2'/,
     &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
     &'m_finite (GeV/c^2)','   y*_subsystem   ','     y*_large     ',
     &'     y*_small     ','    eta*_large    ','    eta*_small    ',
     &'cos(theta*)_large ','cos(theta*)_small ','       x_1        ',
     &'       x_2        ','       x_F        ',' cos(theta_hard)  ',
     &'m''_hard (GeV/c^2) ','       tau        ','        y*        ',
     &'cos(theta_hard^-) ','cos(theta_hard^+) ','      x_T^2       ',
     &'       tau''       '/
 
C...Cross-sections.
      IF(MSTAT.LE.1) THEN
        IF(MINT(121).GT.1) CALL PYSAVE(5,0)
        WRITE(MSTU(11),5000)
        WRITE(MSTU(11),5100)
        WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
        DO 100 I=1,500
          IF(MSUB(I).NE.1) GOTO 100
          WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
  100   CONTINUE
        IF(MINT(121).GT.1) THEN
          WRITE(MSTU(11),5300)
          DO 110 IGA=1,MINT(121)
            CALL PYSAVE(3,IGA)
            IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
              WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
              WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
              WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ELSEIF(MINT(121).EQ.4) THEN
              WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ELSEIF(MINT(121).EQ.2) THEN
              WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ELSE
              WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
     &        XSEC(0,3)
            ENDIF
  110     CONTINUE
          CALL PYSAVE(5,0)
        ENDIF
        WRITE(MSTU(11),5400) 1D0-DBLE(NGEN(0,3))/
     &  MAX(1D0,DBLE(NGEN(0,2)))
 
C...Decay widths and branching ratios.
      ELSEIF(MSTAT.EQ.2) THEN
        WRITE(MSTU(11),5500)
        WRITE(MSTU(11),5600)
        DO 140 KC=1,500
          KF=KCHG(KC,4)
          CALL PYNAME(KF,CHKF)
          IOFF=0
          IF(KC.LE.22) THEN
            IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
            IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
            IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
            IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
            IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
          ELSE
            IF(MWID(KC).LE.0) GOTO 140
            IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
     &      KF/KSUSY1.EQ.2)) GOTO 140
          ENDIF
C...Off-shell branchings.
          IF(IOFF.EQ.1) THEN
            NGP=0
            IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
            IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
     &      PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
            DO 120 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              NGP1=0
              IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
     &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
              NGP2=0
              IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
     &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
              CALL PYNAME(KFDP(IDC,1),CHD1)
              CALL PYNAME(KFDP(IDC,2),CHD2)
              IF(KFDP(IDC,3).EQ.0) THEN
                IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
     &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
     &          CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
              ELSE
                CALL PYNAME(KFDP(IDC,3),CHD3)
                IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
     &          NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
     &          CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
              ENDIF
  120       CONTINUE
C...On-shell decays.
          ELSE
            CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
            BRFIN=1D0
            IF(WDTE(0,0).LE.0D0) BRFIN=0D0
            WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
     &      STATE(MDCY(KC,1)),BRFIN
            DO 130 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              NGP1=0
              IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
     &        (MOD(IABS(KFDP(IDC,1)),10)+1)/2
              NGP2=0
              IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
     &        (MOD(IABS(KFDP(IDC,2)),10)+1)/2
              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),5900) 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),6000)
 
C...Allowed incoming partons/particles at hard interaction.
      ELSEIF(MSTAT.EQ.3) THEN
        WRITE(MSTU(11),6100)
        CALL PYNAME(MINT(11),CHAU)
        CHIN(1)=CHAU(1:12)
        CALL PYNAME(MINT(12),CHAU)
        CHIN(2)=CHAU(1:12)
        WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
        DO 150 I=-20,22
          IF(I.EQ.0) GOTO 150
          IA=IABS(I)
          IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
          IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
          CALL PYNAME(I,CHAU)
          WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
     &    STATE(KFIN(2,I))
  150   CONTINUE
        WRITE(MSTU(11),6400)
 
C...User-defined limits on kinematical variables.
      ELSEIF(MSTAT.EQ.4) THEN
        WRITE(MSTU(11),6500)
        WRITE(MSTU(11),6600)
        SHRMAX=CKIN(2)
        IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
        WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
        PTHMIN=MAX(CKIN(3),CKIN(5))
        PTHMAX=CKIN(4)
        IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
        WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
        WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
        DO 160 I=4,14
          WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
  160   CONTINUE
        SPRMAX=CKIN(32)
        IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
        WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
        WRITE(MSTU(11),7000)
 
C...Status codes and parameter values.
      ELSEIF(MSTAT.EQ.5) THEN
        WRITE(MSTU(11),7100)
        WRITE(MSTU(11),7200)
        DO 170 I=1,100
          WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
     &    PARP(100+I)
  170   CONTINUE
 
C...List of all processes implemented in the program.
      ELSEIF(MSTAT.EQ.6) THEN
        WRITE(MSTU(11),7400)
        WRITE(MSTU(11),7500)
        DO 180 I=1,500
          IF(ISET(I).LT.0) GOTO 180
          WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
  180   CONTINUE
        WRITE(MSTU(11),7700)
      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')
 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
     &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
     &1P,D10.3,0P,1X,'I')
 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
     &'Particles at Hard Interaction',1X,7('*'))
 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
     &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
     &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
     &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
     &78('=')/1X,'I',38X,'I',37X,'I')
 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
     &'Kinematical Variables',1X,12('*'))
 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
     &16X,'I')
 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
     &1X,'<',1X,1P,D10.3,0P,16X,'I')
 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
     &'Parameter Values',1X,12('*'))
 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
     &'PARP(I)'/)
 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
     &1X,13('*'))
 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
     &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
     &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
 
      RETURN
      END
 
C*********************************************************************
 
C...PYINRE
C...Calculates full and effective widths of gauge bosons, stores
C...masses and widths, rescales coefficients to be used for
C...resonance production generation.
 
      SUBROUTINE PYINRE
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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)
      IMPLICIT INTEGER(I-N)
      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*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
     &CHIDNT(3)*12,CHTEMP*12,CHCDE(35)*12,CHINIT*76
      DIMENSION LEN(3),KCDE(35),PM(2)
      DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA CHCDE/    'e-          ','e+          ','nu_e        ',
     &'nu_ebar     ','mu-         ','mu+         ','nu_mu       ',
     &'nu_mubar    ','tau-        ','tau+        ','nu_tau      ',
     &'nu_taubar   ','pi+         ','pi-         ','n0          ',
     &'nbar0       ','p+          ','pbar-       ','gamma       ',
     &'lambda0     ','sigma-      ','sigma0      ','sigma+      ',
     &'xi-         ','xi0         ','omega-      ','pi0         ',
     &'reggeon     ','pomeron     ','gamma/e-    ','gamma/e+    ',
     &'gamma/mu-   ','gamma/mu+   ','gamma/tau-  ','gamma/tau+  '/
      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,6*22/
 
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)=12
        DO 110 LL=12,1,-1
          IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
          DO 100 LA=1,26
            IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
     &      CHALP(1)(LA:LA)
  100     CONTINUE
  110   CONTINUE
        CHIDNT(I)=CHCOM(I)
 
C...Fix up bar, underscore and charge in particle name (if needed).
        DO 120 LL=1,10
          IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
            CHTEMP=CHIDNT(I)
            CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//'  '
          ENDIF
  120   CONTINUE
        IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
          CHTEMP=CHIDNT(I)
          CHIDNT(I)='nu_'//CHTEMP(3:7)
        ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
          CHIDNT(I)(1:3)='n0 '
        ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
          CHIDNT(I)(1:5)='nbar0'
        ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
          CHIDNT(I)(1:3)='p+ '
        ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
     &    CHIDNT(I)(1:2).EQ.'p-') THEN
          CHIDNT(I)(1:5)='pbar-'
        ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
          CHIDNT(I)(7:7)='0'
        ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
          CHIDNT(I)(1:7)='reggeon'
        ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
          CHIDNT(I)(1:7)='pomeron'
        ENDIF
  130 CONTINUE
 
C...Identify free initialization.
      IF(CHCOM(1)(1:2).EQ.'no') THEN
        MINT(65)=1
        RETURN
      ENDIF
 
C...Identify incoming beam and target particles.
      DO 160 I=1,2
        DO 140 J=1,35
          IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
  140   CONTINUE
        PM(I)=PYMASS(MINT(10+I))
        VINT(2+I)=PM(I)
        MINT(140+I)=0
        IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
          CHTEMP=CHIDNT(I+1)(7:12)//' '
          DO 150 J=1,12
            IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
  150     CONTINUE
          PM(I)=PYMASS(MINT(140+I))
          VINT(302+I)=PM(I)
        ENDIF
  160 CONTINUE
      IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
      IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
      IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) 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=(22-(LEN(2)+LEN(3)))/2
          CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
     &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
     &    ' user configuration'//' '
          WRITE(MSTU(11),5200) CHINIT
          WRITE(MSTU(11),5600)
          WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
          WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
          WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
        ENDIF
 
C...Frame defined by user four-vectors.
      ELSEIF(CHCOM(1)(1: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=(22-(LEN(2)+LEN(3)))/2
          CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
     &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
     &    ' user configuration'//' '
          WRITE(MSTU(11),5200) CHINIT
          WRITE(MSTU(11),5600)
          WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
          WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
          WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
        ENDIF
 
C...Frame defined by user five-vectors.
      ELSEIF(CHCOM(1)(1: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=(22-(LEN(2)+LEN(3)))/2
          CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
     &    CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
     &    ' user configuration'//' '
          WRITE(MSTU(11),5200) CHINIT
          WRITE(MSTU(11),5600)
          WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
          WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
          WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
        ENDIF
 
C...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)
      IMPLICIT INTEGER(I-N)
      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)
        IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
  100 CONTINUE
 
C...Reset boost. Do kinematics for various cases.
      DO 110 J=6,10
        VINT(J)=0D0
  110 CONTINUE
 
C...Set up kinematics for events defined in CM frame.
      IF(MINT(111).EQ.1) THEN
        WIN=VINT(290)
        IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
        S=WIN**2
        P(1,5)=VINT(3)
        P(2,5)=VINT(4)
        IF(MINT(141).NE.0) P(1,5)=VINT(303)
        IF(MINT(142).NE.0) P(2,5)=VINT(304)
        P(1,1)=0D0
        P(1,2)=0D0
        P(2,1)=0D0
        P(2,2)=0D0
        P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
     &  (4D0*S))
        P(2,3)=-P(1,3)
        P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
        P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
 
C...Set up kinematics for fixed target events.
      ELSEIF(MINT(111).EQ.2) THEN
        WIN=VINT(290)
        IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
        P(1,5)=VINT(3)
        P(2,5)=VINT(4)
        IF(MINT(141).NE.0) P(1,5)=VINT(303)
        IF(MINT(142).NE.0) P(2,5)=VINT(304)
        P(1,1)=0D0
        P(1,2)=0D0
        P(2,1)=0D0
        P(2,2)=0D0
        P(1,3)=WIN
        P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
        P(2,3)=0D0
        P(2,4)=P(2,5)
        S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
        VINT(10)=P(1,3)/(P(1,4)+P(2,4))
        CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
 
C...Set up kinematics for events in user-defined frame.
      ELSEIF(MINT(111).EQ.3) THEN
        P(1,5)=VINT(3)
        P(2,5)=VINT(4)
        IF(MINT(141).NE.0) P(1,5)=VINT(303)
        IF(MINT(142).NE.0) P(2,5)=VINT(304)
        P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
        P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
        DO 120 J=1,3
          VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
  120   CONTINUE
        CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
        VINT(7)=PYANGL(P(1,1),P(1,2))
        CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
        VINT(6)=PYANGL(P(1,3),P(1,1))
        CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
        S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
 
C...Set up kinematics for events with user-defined four-vectors.
      ELSEIF(MINT(111).EQ.4) THEN
        PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
        P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
        PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
        P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
        DO 130 J=1,3
          VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
  130   CONTINUE
        CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
        VINT(7)=PYANGL(P(1,1),P(1,2))
        CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
        VINT(6)=PYANGL(P(1,3),P(1,1))
        CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
        S=(P(1,4)+P(2,4))**2
 
C...Set up kinematics for events with user-defined five-vectors.
      ELSEIF(MINT(111).EQ.5) THEN
        DO 140 J=1,3
          VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
  140   CONTINUE
        CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
        VINT(7)=PYANGL(P(1,1),P(1,2))
        CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
        VINT(6)=PYANGL(P(1,3),P(1,1))
        CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
        S=(P(1,4)+P(2,4))**2
      ENDIF
 
C...Return or error for too low CM energy.
      IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
        IF(MSTP(172).LE.1) THEN
          CALL PYERRM(23,
     &    '(PYINKI:) too low invariant mass in this event')
        ELSE
          MSTI(61)=1
          RETURN
        ENDIF
      ENDIF
 
C...Save information on incoming particles.
      VINT(1)=SQRT(S)
      VINT(2)=S
      IF(MINT(111).GE.4) THEN
        IF(MINT(141).EQ.0) THEN
          VINT(3)=P(1,5)
          IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
        ELSE
          VINT(303)=P(1,5)
        ENDIF
        IF(MINT(142).EQ.0) THEN
          VINT(4)=P(2,5)
          IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
        ELSE
          VINT(304)=P(2,5)
        ENDIF
      ENDIF
      VINT(5)=P(1,3)
      IF(MODKI.EQ.0) VINT(289)=S
      DO 150 J=1,5
        V(1,J)=0D0
        V(2,J)=0D0
        VINT(290+J)=P(1,J)
        VINT(295+J)=P(2,J)
  150 CONTINUE
 
C...Store pT cut-off and related constants to be used in generation.
      IF(MODKI.EQ.0) VINT(285)=CKIN(3)
      IF(MSTP(82).LE.1) THEN
        PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
      ELSE
        PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
      ENDIF
      VINT(149)=4D0*PTMN**2/S
      VINT(154)=PTMN
 
      RETURN
      END
 
C*********************************************************************
 
C...PYINPR
C...Selects partonic subprocesses to be included in the simulation.
 
      SUBROUTINE PYINPR
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...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...Set running pTmin scale.
      IF(MSTP(82).LE.1) THEN
        PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
      ELSE
        PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
      ENDIF

C...Begin by assuming incoming photon to enter subprocess.
      IF(MINT(11).EQ.22) MINT(15)=22
      IF(MINT(12).EQ.22) MINT(16)=22
 
C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
      IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
        MSUB(10)=1
        MINT(123)=MINT(122)+1
 
C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 
C...allow mixture.
C...Here also set a few parameters otherwise normally not touched.
      ELSEIF(MINT(121).GT.1) THEN
 
C...Parton distributions dampened at small Q2; go to low energies,
C...alpha_s <1; no minimum pT cut-off a priori.
        IF(MSTP(18).EQ.2) THEN
          MSTP(57)=3
          PARP(2)=2D0
          PARU(115)=1D0
          CKIN(5)=0.2D0
          CKIN(6)=0.2D0
        ENDIF 
 
C...Define pT cut-off parameters and whether run involves low-pT.
        PTMVMD=PTMRUN
        VINT(154)=PTMVMD
        PTMDIR=PTMVMD
        IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
        PTMANO=PTMVMD
        IF(MSTP(15).EQ.5) PTMANO=0.60D0+
     &  0.125D0*LOG(1D0+0.10D0*VINT(1))**2
        IPTL=1
        IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
        IF(MSEL.EQ.2) IPTL=1
 
C...Set up for p/gamma * gamma; real or virtual photons.
        IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
     &  MSTP(14).EQ.30)) THEN
 
C...Set up for p/VMD * VMD.
        IF(MINT(122).EQ.1) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
 
C...Set up for p/VMD * direct gamma.
        ELSEIF(MINT(122).EQ.2) THEN
          MINT(123)=0
          IF(MINT(121).EQ.6) MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for p/VMD * anomalous gamma.
        ELSEIF(MINT(122).EQ.3) THEN
          MINT(123)=3
          IF(MINT(121).EQ.6) MINT(123)=7
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0

C...Set up for DIS * p.
        ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GE.28.OR.
     &  IABS(MINT(12)).GE.28)) THEN
          MINT(123)=8
          IF(IPTL.EQ.1) MSUB(99)=1
 
C...Set up for direct * direct gamma (switch off leptons).
        ELSEIF(MINT(122).EQ.4) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  110     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for direct * anomalous gamma.
        ELSEIF(MINT(122).EQ.5) THEN
          MINT(123)=6
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMANO
 
C...Set up for anomalous * anomalous gamma.
        ELSEIF(MINT(122).EQ.6) THEN
          MINT(123)=3
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF
 
C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
        ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
 
C...Set up for direct * direct gamma (switch off leptons).
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  120     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for direct * VMD and VMD * direct gamma.
        ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
          MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for direct * anomalous and anomalous * direct gamma.
        ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
          MINT(123)=6
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMANO
 
C...Set up for VMD*VMD.
        ELSEIF(MINT(122).EQ.5) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
 
C...Set up for VMD * anomalous and anomalous * VMD gamma.
        ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
          MINT(123)=7
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
 
C...Set up for anomalous * anomalous gamma.
        ELSEIF(MINT(122).EQ.9) THEN
          MINT(123)=3
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
 
C...Set up for DIS * VMD and VMD * DIS gamma.
        ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
          MINT(123)=8
          IF(IPTL.EQ.1) MSUB(99)=1
 
C...Set up for DIS * anomalous and anomalous * DIS gamma.
        ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
          MINT(123)=9
          IF(IPTL.EQ.1) MSUB(99)=1
        ENDIF
 
C...Set up for gamma* * p; virtual photons = dir, res.
        ELSEIF(MINT(121).EQ.2) THEN
 
C...Set up for direct * p.
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for resolved * p.
        ELSEIF(MINT(122).EQ.2) THEN
          MINT(123)=1
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF
 
C...Set up for gamma* * gamma*; virtual photons = dir, res.
        ELSEIF(MINT(121).EQ.4) THEN
 
C...Set up for direct * direct gamma (switch off leptons).
        IF(MINT(122).EQ.1) THEN
          MINT(123)=0
          MSUB(137)=1
          MSUB(138)=1
          MSUB(139)=1
          MSUB(140)=1
          DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
            IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
  130     CONTINUE
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for direct * resolved and resolved * direct gamma.
        ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
          MINT(123)=5
          MSUB(131)=1
          MSUB(132)=1
          MSUB(135)=1
          MSUB(136)=1
          IF(IPTL.EQ.1) CKIN(3)=PTMDIR
 
C...Set up for resolved * resolved gamma.
        ELSEIF(MINT(122).EQ.4) THEN
          MINT(123)=2
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          IF(IPTL.EQ.1) MSUB(95)=1
          IF(MSEL.EQ.2) THEN
            MSUB(91)=1
            MSUB(92)=1
            MSUB(93)=1
            MSUB(94)=1
          ENDIF
          IF(IPTL.EQ.1) CKIN(3)=0D0
        ENDIF
 
C...End of special set up for gamma-p and gamma-gamma.
        ENDIF
        CKIN(1)=2D0*CKIN(3)
      ENDIF
 
C...Flavour information for individual beams.
      DO 140 I=1,2
        MINT(40+I)=1
        IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
        IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
        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.OR.
     &  IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
  140 CONTINUE
 
C...If two real gammas, whereof one direct, pick the first.
C...For two virtual photons, keep requested order.
      IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
        IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
     &  MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
     &  MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
          MINT(42)=1
          MINT(46)=1
        ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
     &  .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
     &  .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
          MINT(42)=1
          MINT(46)=1
        ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
          MINT(41)=1
          MINT(45)=1
        ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
          MINT(42)=1
          MINT(46)=1
        ENDIF
      ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
        IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
          IF(MINT(11).EQ.22) THEN
            MINT(41)=1
            MINT(45)=1
          ELSE
            MINT(42)=1
            MINT(46)=1
          ENDIF
        ENDIF 
        IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
     &  '(PYINPR:) unallowed MSTP(14) code for single photon')
      ENDIF
 
C...Flavour information on combination of incoming particles.
      MINT(43)=2*MINT(41)+MINT(42)-2
      MINT(44)=MINT(43)
      IF(MINT(123).LE.0) THEN
        IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
        IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
      ELSEIF(MINT(123).LE.3) THEN
        IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
        IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
      ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
        MINT(43)=4
        MINT(44)=1
      ENDIF
      MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
      IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
      IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
      IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
      MINT(50)=0
      IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1
      MINT(107)=0
      MINT(108)=0
      IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
        IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) 
     &  MINT(107)=2
        IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) 
     &  MINT(107)=3
        IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
        IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
     &  MINT(122).EQ.10) MINT(108)=2
        IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
     &  MINT(122).EQ.11) MINT(108)=3
        IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
      ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
        IF(MINT(122).GE.3) MINT(107)=1
        IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
      ELSEIF(MINT(121).EQ.2) THEN
        IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
        IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
      ELSE
        IF(MINT(11).EQ.22) THEN
          MINT(107)=MINT(123)
          IF(MINT(123).GE.4) MINT(107)=0
          IF(MINT(123).EQ.7) MINT(107)=2
          IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
          IF(MSTP(14).EQ.28) MINT(107)=2
          IF(MSTP(14).EQ.29) MINT(107)=3
          IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) 
     &    MINT(107)=4
        ENDIF
        IF(MINT(12).EQ.22) THEN
          MINT(108)=MINT(123)
          IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
          IF(MINT(123).EQ.7) MINT(108)=3
          IF(MSTP(14).EQ.26) MINT(108)=2
          IF(MSTP(14).EQ.27) MINT(108)=3
          IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
          IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) 
     &    MINT(108)=4
        ENDIF
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
     &  MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
          MINTTP=MINT(107)
          MINT(107)=MINT(108)
          MINT(108)=MINTTP
        ENDIF
      ENDIF
      IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
      IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
 
C...Select default processes according to incoming beams
C...(already done for gamma-p and gamma-gamma with 
C...MSTP(14) = 10, 20, 25 or 30).
      IF(MINT(121).GT.1) THEN
      ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
 
        IF(MINT(43).EQ.1) THEN
C...Lepton + lepton -> gamma/Z0 or W.
          IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
          IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
 
        ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
     &    (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
C...Unresolved photon + lepton: Compton scattering.
          MSUB(133)=1
          MSUB(134)=1

        ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
     &  .OR.MINT(12).EQ.22)) THEN
C...DIS as pure gamma* + f -> f process.
          MSUB(99)=1  
 
        ELSEIF(MINT(43).LE.3) THEN
C...Lepton + hadron: deep inelastic scattering.
          MSUB(10)=1
 
        ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
     &    MINT(12).EQ.22) THEN
C...Two unresolved photons: fermion pair production, 
C...exclude lepton pairs.
          DO 150 ISUB=137,140
            MSUB(ISUB)=1
  150     CONTINUE
          DO 155 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))
  155     CONTINUE
          PTMDIR=PTMRUN
          IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
          IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
          CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) 
 
        ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
     &    .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
     &    MINT(12).EQ.22)) THEN
C...Unresolved photon + hadron: photon-parton scattering.
          DO 160 ISUB=131,136
            MSUB(ISUB)=1
  160     CONTINUE
 
        ELSEIF(MSEL.EQ.1) THEN
C...High-pT QCD processes:
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          PTMN=PTMRUN
          VINT(154)=PTMN
          IF(CKIN(3).LT.PTMN) MSUB(95)=1
          IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
 
        ELSE
C...All QCD processes:
          MSUB(11)=1
          MSUB(12)=1
          MSUB(13)=1
          MSUB(28)=1
          MSUB(53)=1
          MSUB(68)=1
          MSUB(91)=1
          MSUB(92)=1
          MSUB(93)=1
          MSUB(94)=1
          MSUB(95)=1
        ENDIF
 
      ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
C...Heavy quark production.
        MSUB(81)=1
        MSUB(82)=1
        MSUB(84)=1
        DO 170 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  170   CONTINUE
        MDME(MDCY(21,2)+MSEL-1,1)=1
        MSUB(85)=1
        DO 180 J=1,MIN(12,MDCY(22,3))
          MDME(MDCY(22,2)+J-1,1)=0
  180   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 190 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  190   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 200 I=201,301
            IF(ISET(I).GE.0) MSUB(I)=1
  200     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
C...Lepton-lepton processes: QED production of squarks.
          DO 210 I=201,214
            MSUB(I)=1
  210     CONTINUE
          MSUB(210)=0
          MSUB(211)=0
          MSUB(212)=0
          DO 220 I=216,228
            MSUB(I)=1
  220     CONTINUE
          DO 230 I=261,263
            MSUB(I)=1
  230     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 240 I=271,296
            MSUB(I)=1
  240     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 250 I=201,214
          MSUB(I)=1
  250   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 260 I=237,242
            MSUB(I)=1
  260     CONTINUE
          DO 270 I=246,257
            MSUB(I)=1
  270     CONTINUE
        ENDIF
 
      ELSEIF(MSEL.EQ.44) THEN
C...Neutralino/Chargino pair production.
        IF(MINT(43).EQ.4) THEN
          DO 280 I=216,236
            MSUB(I)=1
  280     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
          DO 290 I=216,228
            MSUB(I)=1
  290     CONTINUE
        ENDIF
 
      ELSEIF(MSEL.EQ.45) THEN
C...Sbottom production.
        MSUB(287)=1
        MSUB(288)=1
        IF(MINT(43).EQ.4) THEN
          DO 300 I=281,296
            MSUB(I)=1
  300     CONTINUE
        ENDIF

      ELSEIF(MSEL.EQ.50) THEN
        DO 305 I=361,368
          MSUB(I)=1
  305   CONTINUE
        IF(MINT(43).EQ.4) THEN
          DO 307 I=370,377
            MSUB(I)=1
  307     CONTINUE
        ENDIF

      ENDIF
 
C...Find heaviest new quark flavour allowed in processes 81-84.
      KFLQM=1
      DO 310 I=1,MIN(8,MDCY(21,3))
        IDC=I+MDCY(21,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 310
        KFLQM=I
  310 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 320 I=1,MIN(12,MDCY(22,3))
        IDC=I+MDCY(22,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 320
        KFLFM=KFDP(IDC,1)
  320 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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
      COMMON/PYINT7/SIGT(0:6,0:6,0:5)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
C...Local arrays.
      DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
     &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
     &CEFFD(10,9),SIGTMP(6,0:5)
 
C...Common constants.
      DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
     &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
     &FACDD/0.0084D0/
 
C...Number of multiple processes to be evaluated (= 0 : undefined).
      DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
      DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
     &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
     &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
      DATA YPAR/
     &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
     &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
     &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
 
C...Beam and target hadron class:
C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
      DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
      DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
C...Characteristic class masses, slope parameters, beta = sqrt(X).
      DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
      DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
      DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
 
C...Fitting constants used in parametrizations of diffractive results.
      DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
      DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
      DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
     &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
     &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
     &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
     &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
     &0.267D0, 0.0D0, -0.46D0,  75D0, 0.267D0, 0.0D0, -0.46D0,  75D0,
     &0.232D0, 0.0D0, -0.46D0,  85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
     &0.115D0, 0.0D0, -0.50D0,  90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
     &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
     &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
     &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
      DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
     &3.11D0, -7.34D0,  9.71D0, 0.068D0, -0.42D0,  1.31D0,
     &-1.37D0,  35.0D0,  118D0,  3.11D0, -7.10D0,  10.6D0,
     &0.073D0, -0.41D0, 1.17D0, -1.41D0,  31.6D0,   95D0,
     &3.12D0, -7.43D0,  9.21D0, 0.067D0, -0.44D0,  1.41D0,
     &-1.35D0,  36.5D0,  132D0,  3.13D0, -8.18D0, -4.20D0,
     &0.056D0, -0.71D0, 3.12D0, -1.12D0,  55.2D0, 1298D0,
     &3.11D0, -6.90D0,  11.4D0, 0.078D0, -0.40D0,  1.05D0,
     &-1.40D0,  28.4D0,   78D0,  3.11D0, -7.13D0,  10.0D0,
     &0.071D0, -0.41D0, 1.23D0, -1.34D0,  33.1D0,  105D0,
     &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0,  2.72D0,
     &-1.13D0,  53.1D0,  995D0,  3.11D0, -7.39D0,  8.22D0,
     &0.065D0, -0.44D0, 1.45D0, -1.36D0,  38.1D0,  148D0,
     &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0,  3.32D0,
     &-1.12D0,  55.6D0, 1472D0,  4.18D0, -29.2D0,  56.2D0,
     &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
 
C...Parameters. Combinations of the energy.
      AEM=PARU(101)
      PMTH=PARP(102)
      S=VINT(2)
      SRT=VINT(1)
      SEPS=S**EPS
      SETA=S**ETA
      SLOG=LOG(S)
 
C...Ratio of gamma/pi (for rescaling in parton distributions).
      VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
     &(XPAR(5)*SEPS+YPAR(5)*SETA)
      VINT(317)=1D0 
      IF(MINT(50).NE.1) RETURN
 
C...Order flavours of incoming particles: KF1 < KF2.
      IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
        KF1=IABS(MINT(11))
        KF2=IABS(MINT(12))
        IORD=1
      ELSE
        KF1=IABS(MINT(12))
        KF2=IABS(MINT(11))
        IORD=2
      ENDIF
      ISGN12=ISIGN(1,MINT(11)*MINT(12))
 
C...Find process number (for lookup tables).
      IF(KF1.GT.1000) THEN
        IPROC=1
        IF(ISGN12.LT.0) IPROC=2
      ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
        IPROC=3
        IF(ISGN12.LT.0) IPROC=4
        IF(KF1.EQ.111) IPROC=5
      ELSEIF(KF1.GT.100) THEN
        IPROC=11
      ELSEIF(KF2.GT.1000) THEN
        IPROC=21
        IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
      ELSEIF(KF2.GT.100) THEN
        IPROC=23
        IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
      ELSE
        IPROC=25
        IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
      ENDIF
 
C... Number of multiple processes to be stored; beam/target side.
      NPR=NPROC(IPROC)
      MINT(101)=1
      MINT(102)=1
      IF(NPR.EQ.3) THEN
        MINT(100+IORD)=4
      ELSEIF(NPR.EQ.6) THEN
        MINT(101)=4
        MINT(102)=4
      ENDIF
      N1=0
      IF(MINT(101).EQ.4) N1=4
      N2=0
      IF(MINT(102).EQ.4) N2=4
 
C...Do not do any more for user-set or undefined cross-sections.
      IF(MSTP(31).LE.0) RETURN
      IF(NPR.EQ.0) CALL PYERRM(26,
     &'(PYXTOT:) cross section for this process not yet implemented')
 
C...Parameters. Combinations of the energy.
      AEM=PARU(101)
      PMTH=PARP(102)
      S=VINT(2)
      SRT=VINT(1)
      SEPS=S**EPS
      SETA=S**ETA
      SLOG=LOG(S)
 
C...Loop over multiple processes (for VDM).
      DO 110 I=1,NPR
        IF(NPR.EQ.1) THEN
          IPR=IPROC
        ELSEIF(NPR.EQ.3) THEN
          IPR=I+4
          IF(KF2.LT.1000) IPR=I+10
        ELSEIF(NPR.EQ.6) THEN
          IPR=I+10
        ENDIF
 
C...Evaluate hadron species, mass, slope contribution and fit number.
        IHA=IHADA(IPR)
        IHB=IHADB(IPR)
        PMA=PMHAD(IHA)
        PMB=PMHAD(IHB)
        BHA=BHAD(IHA)
        BHB=BHAD(IHB)
        ISD=IFITSD(IPR)
        IDD=IFITDD(IPR)
 
C...Skip if energy too low relative to masses.
        DO 100 J=0,5
          SIGTMP(I,J)=0D0
  100   CONTINUE
        IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
 
C...Total cross-section. Elastic slope parameter and cross-section.
        SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
        BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
        SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
 
C...Diffractive scattering A + B -> X + B.
        BSD=2D0*BHB
        SQML=(PMA+PMTH)**2
        SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
        SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
     &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
        BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
        SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
     &  (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
        SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
 
C...Diffractive scattering A + B -> A + X.
        BSD=2D0*BHA
        SQML=(PMB+PMTH)**2
        SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
        SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
     &  (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
        BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
        SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
     &  (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
        SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
 
C...Order single diffractive correctly.
        IF(IORD.EQ.2) THEN
          SIGSAV=SIGTMP(I,2)
          SIGTMP(I,2)=SIGTMP(I,3)
          SIGTMP(I,3)=SIGSAV
        ENDIF
 
C...Double diffractive scattering A + B -> X1 + X2.
        YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
        DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
        SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP)
        IF(YEFF.LE.0) SUM1=0D0
        SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
        SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
        SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
        SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
     &  (2D0*ALP)
        SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
        SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
        SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
     &  (2D0*ALP)
        BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
        SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC)))
        SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
     &  LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
        SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
 
C...Non-diffractive by unitarity.
        SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
     &  SIGTMP(I,4)
  110 CONTINUE
 
C...Put temporary results in output array: only one process.
      IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
        DO 120 J=0,5
          SIGT(0,0,J)=SIGTMP(1,J)
  120   CONTINUE
 
C...Beam multiple processes.
      ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
        IF(MINT(107).EQ.2) THEN
          VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
        ELSE
          VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
     &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
        ENDIF
        IF(MSTP(20).GT.0) THEN
          VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
        ENDIF
        DO 140 I=1,4
          IF(MINT(107).EQ.2) THEN
            CONV=(AEM/PARP(160+I))*VINT(317)
          ELSEIF(VINT(154).GT.PARP(15)) THEN
            CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
     &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
          ELSE
            CONV=0D0
          ENDIF
          I1=MAX(1,I-1)
          DO 130 J=0,5
            SIGT(I,0,J)=CONV*SIGTMP(I1,J)
  130     CONTINUE
  140   CONTINUE
        DO 150 J=0,5
          SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
  150   CONTINUE
 
C...Target multiple processes.
      ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
        IF(MINT(108).EQ.2) THEN
          VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
        ELSE
          VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
     &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
        ENDIF
        IF(MSTP(20).GT.0) THEN
          VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
        ENDIF
        DO 170 I=1,4
          IF(MINT(108).EQ.2) THEN
            CONV=(AEM/PARP(160+I))*VINT(317)
          ELSEIF(VINT(154).GT.PARP(15)) THEN
            CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
     &      (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
          ELSE
            CONV=0D0
          ENDIF
          IV=MAX(1,I-1)
          DO 160 J=0,5
            SIGT(0,I,J)=CONV*SIGTMP(IV,J)
  160     CONTINUE
  170   CONTINUE
        DO 180 J=0,5
          SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
  180   CONTINUE
 
C...Both beam and target multiple processes.
      ELSE
        IF(MINT(107).EQ.2) THEN
          VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
        ELSE
          VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
     &    ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
        ENDIF
        IF(MINT(108).EQ.2) THEN
          VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
        ELSE
          VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
     &    ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
        ENDIF
        IF(MSTP(20).GT.0) THEN
          VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
     &    VINT(308)))**MSTP(20)
        ENDIF
        DO 210 I1=1,4
          DO 200 I2=1,4
            IF(MINT(107).EQ.2) THEN
              CONV=(AEM/PARP(160+I1))*VINT(317)
            ELSEIF(VINT(154).GT.PARP(15)) THEN
              CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
     &        (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
            ELSE
              CONV=0D0
            ENDIF
            IF(MINT(108).EQ.2) THEN
              CONV=CONV*(AEM/PARP(160+I2))
            ELSEIF(VINT(154).GT.PARP(15)) THEN
              CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
     &        (1D0/PARP(15)**2-1D0/VINT(154)**2)
            ELSE
              CONV=0D0
            ENDIF
            IF(I1.LE.2) THEN
              IV=MAX(1,I2-1)
            ELSEIF(I2.LE.2) THEN
              IV=MAX(1,I1-1)
            ELSEIF(I1.EQ.I2) THEN
              IV=2*I1-2
            ELSE
              IV=5
            ENDIF
            DO 190 J=0,5
              JV=J
              IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
              SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
  190       CONTINUE
  200     CONTINUE
  210   CONTINUE
        DO 230 J=0,5
          DO 220 I=1,4
            SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
            SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
  220     CONTINUE
          SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
  230   CONTINUE
      ENDIF
 
C...Scale up uniformly for Donnachie-Landshoff parametrization.
      IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
        RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
        DO 260 I1=0,N1
          DO 250 I2=0,N2
            DO 240 J=0,5
              SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
  240       CONTINUE
  250     CONTINUE
  260   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMAXI
C...Finds optimal set of coefficients for kinematical variable selection
C...and the maximum of the part of the differential cross-section used
C...in the event weighting.
 
      SUBROUTINE PYMAXI
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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...Initial values and loop over subprocesses.
      NPOSI=0
      VINT(143)=1D0
      VINT(144)=1D0
      XSEC(0,1)=0D0
      DO 460 ISUB=1,500
        MINT(1)=ISUB
        MINT(51)=0
 
C...Find maximum weight factors for photon flux.
        IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
        ENDIF 

C...Select subprocess to study: skip cases not applicable.
        IF(ISET(ISUB).EQ.11) THEN
          IF(MSUB(ISUB).NE.1) GOTO 460
          XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1)
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
     &    WTGAGA*XSEC(ISUB,1)
          NPOSI=NPOSI+1
          GOTO 450
        ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
          CALL PYSIGH(NCHN,SIGS)
          XSEC(ISUB,1)=SIGS
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
     &    WTGAGA*XSEC(ISUB,1)
          IF(MSUB(ISUB).NE.1) GOTO 460
          NPOSI=NPOSI+1
          GOTO 450
        ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
          CALL PYSIGH(NCHN,SIGS)
          XSEC(ISUB,1)=SIGS
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
     &    WTGAGA*XSEC(ISUB,1)
          IF(XSEC(ISUB,1).EQ.0D0) THEN
            MSUB(ISUB)=0
          ELSE
            NPOSI=NPOSI+1
          ENDIF
          GOTO 450
        ELSEIF(ISUB.EQ.96) THEN
          IF(MINT(50).EQ.0) GOTO 460
          IF(MSUB(95).NE.1.AND.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
        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
        ELSEIF(ISUB.EQ.195) THEN
          KFR1=55
        ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
          KFR1=54
        ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
          KFR1=55
        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)
          IF(KFR1.EQ.54) THEN
            CALL PYTECM(S1,S2)
            TAUR1=S1/VINT(2)
          ENDIF
          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.OR.(ISUB.GE.364.AND.ISUB.LE.368))
     $  THEN
          KFR2=23
          IF(ISUB.EQ.194) THEN
            KFR2=56
          ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
            KFR2=56
          ENDIF
          KCR2=PYCOMP(KFR2)
          TAUR2=PMAS(KCR2,1)**2/VINT(2)
          IF(KFR2.EQ.56) THEN
            CALL PYTECM(S1,S2)
            TAUR2=S2/VINT(2)
          ENDIF
          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) THEN
            VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
          ELSEIF(ISUB.EQ.96) THEN
            VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
          ENDIF
        ENDIF
        VINT(63)=SQM3
        VINT(64)=SQM4
 
C...Prepare for additional variable choices in 2 -> 3.
        IF(ISTSB.EQ.5) THEN
          VINT(201)=0D0
          IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
          VINT(206)=VINT(201)
          VINT(204)=PMAS(23,1)
          IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
          IF(ISUB.EQ.352) VINT(204)=PMAS(63,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).GE.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).GE.5) NPTS(2)=3
        ENDIF
        NPTS(3)=1
        IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
          NPTS(3)=3
          IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
          IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
        ENDIF
        NPTS(4)=1
        IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
        NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
 
C...Reset coefficients of cross-section weighting.
        DO 120 J=1,20
          COEF(ISUB,J)=0D0
  120   CONTINUE
        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-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
        ENDIF
 
C...Reset. Sum up cross-sections in points calculated.
        DO 320 IVAR=1,4
          IF(NPTS(IVAR).EQ.1) GOTO 320
          IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
          NBIN=NPTS(IVAR)
          DO 170 J1=1,NBIN
            NAREL(J1)=0
            WTREL(J1)=0D0
            COEFU(J1)=0D0
            DO 160 J2=1,NBIN
              WTMAT(J1,J2)=0D0
  160       CONTINUE
  170     CONTINUE
          DO 180 IACC=1,NACC
            IBIN=MVARPT(IACC,IVAR)
            IF(IVAR.EQ.1.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-10,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-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
                WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
     &          TAUP/MAX(2D-10,1D0-TAUP)
              ENDIF
 
C...Sum up y* cross-section pieces in points used.
            ELSEIF(IVAR.EQ.3) THEN
              YST=VINTPT(IACC,12)
              YSTMIN=VINTPT(IACC,2)
              YSTMAX=VINTPT(IACC,22)
              AYST0=YSTMAX-YSTMIN
              AYST1=0.5D0*(YSTMAX-YSTMIN)**2
              AYST2=AYST1
              AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
              WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
              WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
              WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
              IF(MINT(45).EQ.3) THEN
                TAUE=VINTPT(IACC,11)
                IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
                YST0=-0.5D0*LOG(TAUE)
                AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
     &          MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
                WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
     &          MAX(1D-10,1D0-EXP(YST-YST0))
              ENDIF
              IF(MINT(46).EQ.3) THEN
                TAUE=VINTPT(IACC,11)
                IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
                YST0=-0.5D0*LOG(TAUE)
                AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
     &          MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
                WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
     &          MAX(1D-10,1D0-EXP(-YST-YST0))
              ENDIF
 
C...Sum up cos(theta-hat) cross-section pieces in points used.
            ELSE
              RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
              RSQM=1D0+RM34
              CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
              CTHMIN=-CTHMAX
              IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
     &        (TAUMAX*VINT(2)))
              ACTH1=CTHMAX-CTHMIN
              ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
              ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
              ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
              ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
              CTH=VINTPT(IACC,13)
              WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
              WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
     &        MAX(RM34,RSQM-CTH)
              WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
     &        MAX(RM34,RSQM+CTH)
              WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
     &        MAX(RM34,RSQM-CTH)**2
              WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
     &        MAX(RM34,RSQM+CTH)**2
            ENDIF
  180     CONTINUE
 
C...Check that equation system solvable.
          IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
          MSOLV=1
          WTRELS=0D0
          DO 190 IBIN=1,NBIN
            IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
     &      IRED=1,NBIN),WTREL(IBIN)
            IF(NAREL(IBIN).EQ.0) MSOLV=0
            WTRELS=WTRELS+WTREL(IBIN)
  190     CONTINUE
          IF(ABS(WTRELS).LT.1D-20) MSOLV=0
 
C...Solve to find relative importance of cross-section pieces.
          IF(MSOLV.EQ.1) THEN
            DO 200 IBIN=1,NBIN
              WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
  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.
                ILERR=0
                IF(IVAR.EQ.1) THEN
                  VTAU=VNEW
                  CALL PYKMAP(1,MTAU,VTAU)
                  IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
                    CALL PYKLIM(4)
                    IF(MINT(51).EQ.1) ILERR=1
                  ENDIF
                ENDIF
                IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
     &          ILERR.EQ.0) THEN
                  IF(IVAR.EQ.2) VTAUP=VNEW
                  CALL PYKMAP(4,MTAUP,VTAUP)
                ENDIF
                IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
                  CALL PYKLIM(2)
                  IF(MINT(51).EQ.1) ILERR=1
                ENDIF
                IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
                  IF(IVAR.EQ.3) VYST=VNEW
                  CALL PYKMAP(2,MYST,VYST)
                  CALL PYKLIM(3)
                  IF(MINT(51).EQ.1) ILERR=1
                ENDIF
                IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
     &          ILERR.EQ.0) THEN
                  IF(IVAR.EQ.4) VCTH=VNEW
                  CALL PYKMAP(3,MCTH,VCTH)
                ENDIF
                IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
 
C...Evaluate cross-section. Save new maximum. Final maximum.
                IF(ILERR.NE.0) THEN
                   SIGS=0.
                ELSEIF(ISTSB.NE.5) THEN
                  CALL PYSIGH(NCHN,SIGS)
                  IF(MWTXS.EQ.1) THEN
                    CALL PYEVWT(WTXS)
                    SIGS=WTXS*SIGS
                  ENDIF
                ELSE
                  SIGS=0D0
                  DO 400 IKIN3=1,MSTP(129)
                    CALL PYKMAP(5,0,0D0)
                    IF(MINT(51).EQ.1) GOTO 400
                    CALL PYSIGH(NCHN,SIGTMP)
                    IF(MWTXS.EQ.1) THEN
                        CALL PYEVWT(WTXS)
                        SIGTMP=WTXS*SIGTMP
                    ENDIF
                    IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
  400             CONTINUE
                ENDIF
                SIGSSM(INEW)=SIGS
                IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
                IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
     &          IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
  410         CONTINUE
  420       CONTINUE
  430     CONTINUE
  440   CONTINUE
        IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
        XSEC(ISUB,1)=1.05D0*SIGSAM
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
     &  WTGAGA*XSEC(ISUB,1)
  450   CONTINUE
        IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
     &  PARP(174)*XSEC(ISUB,1)
        IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
  460 CONTINUE
      MINT(51)=0
 
C...Print summary table.
      IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
        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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT7/SIGT(0:6,0:6,0:5)
      SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
C...Local arrays and saved variables.
      DIMENSION WTI(0:200)
      SAVE IMIN,IMAX,WTI,WTS
 
C...Sum of allowed cross-sections for pileup events.
      IF(MPILE.EQ.1) THEN
        VINT(131)=SIGT(0,0,5)
        IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
        IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
        IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
        IF(MSTP(133).LE.0) RETURN
 
C...Initialize multiplicity distribution at maximum.
        XNAVE=VINT(131)*PARP(131)
        IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
        INAVE=MAX(1,MIN(200,NINT(XNAVE)))
        WTI(INAVE)=1D0
        WTS=WTI(INAVE)
        WTN=WTI(INAVE)*INAVE
 
C...Find shape of multiplicity distribution below maximum.
        IMIN=INAVE
        DO 100 I=INAVE-1,1,-1
          IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
          IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
          IF(WTI(I).LT.1D-6) GOTO 110
          WTS=WTS+WTI(I)
          WTN=WTN+WTI(I)*I
          IMIN=I
  100   CONTINUE
 
C...Find shape of multiplicity distribution above maximum.
  110   IMAX=INAVE
        DO 120 I=INAVE+1,200
          IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
          IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
          IF(WTI(I).LT.1D-6) GOTO 130
          WTS=WTS+WTI(I)
          WTN=WTN+WTI(I)*I
          IMAX=I
  120   CONTINUE
  130   VINT(132)=XNAVE
        VINT(133)=WTN/WTS
        IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
     &  WTS/(WTS+WTI(1)/XNAVE)
        IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
        IF(MSTP(133).GE.2) VINT(134)=XNAVE
 
C...Pick multiplicity of pileup events.
      ELSE
        IF(MSTP(133).LE.0) THEN
          MINT(81)=MAX(1,MSTP(134))
        ELSE
          WTR=WTS*PYR(0)
          DO 140 I=IMIN,IMAX
            MINT(81)=I
            WTR=WTR-WTI(I)
            IF(WTR.LE.0D0) GOTO 150
  140     CONTINUE
  150     CONTINUE
        ENDIF
      ENDIF
 
C...Format statement for error message.
 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
     &'crossing too large, ',1P,D12.4)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSAVE
C...Saves and restores parameter and cross section values for the
C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alnternatives.
C...Also makes random choice between alternatives.
 
      SUBROUTINE PYSAVE(ISAVE,IGA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
      COMMON/PYINT7/SIGT(0:6,0:6,0:5)
      SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
C...Local arrays and saved variables.
      DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
     &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
     &INTCP(15,20),RECP(15,20)
      SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
 
C...Save list of subprocesses and cross-section information.
      IF(ISAVE.EQ.1) THEN
        ICP=0
        DO 120 I=1,500
          IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
          ICP=ICP+1
          NSUBCP(IGA,ICP)=I
          MSUBCP(IGA,ICP)=MSUB(I)
          DO 100 J=1,20
            COEFCP(IGA,ICP,J)=COEF(I,J)
  100     CONTINUE
          DO 110 J=1,3
            NGENCP(IGA,ICP,J)=NGEN(I,J)
            XSECCP(IGA,ICP,J)=XSEC(I,J)
  110     CONTINUE
  120   CONTINUE
        NCP(IGA)=ICP
        DO 130 J=1,3
          NGENCP(IGA,0,J)=NGEN(0,J)
          XSECCP(IGA,0,J)=XSEC(0,J)
  130   CONTINUE
        DO 136 I1=0,6
          DO 134 I2=0,6
            DO 132 J=0,5
              SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
  132       CONTINUE
  134     CONTINUE
  136   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)
        RECP(IGA,2)=VINT(318)
 
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
        DO 256 I1=0,6
          DO 254 I2=0,6
            DO 252 J=0,5
              SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
  252       CONTINUE
  254     CONTINUE
  256   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)
        VINT(318)=RECP(IGA,2)
 
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...PYGAGA
C...For lepton beams it gives photon-hadron or photon-photon systems
C...to be treated with the ordinary machinery and combines this with a
C...description of the lepton -> lepton + photon branching.
 
      SUBROUTINE PYGAGA(IGAGA,WTGAGA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT5/
C...Local variables and data statement.
      DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
     &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
      SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
      DATA EPS/1D-4/
 
C...Initialize generation of photons inside leptons.
      IF(IGAGA.EQ.1) THEN
 
C...Save quantities on incoming lepton system.
        VINT(301)=VINT(1)
        VINT(302)=VINT(2)
        PMS(1)=VINT(303)**2
        IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
        PMS(2)=VINT(304)**2
        IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
        PMC(3)=VINT(302)-PMS(1)-PMS(2)
        W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
 
C...Calculate range of x and Q2 values allowed in generation.
        DO 100 I=1,2
          PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
          IF(MINT(140+I).NE.0) THEN
            XMIN(I)=MAX(CKIN(59+2*I),EPS)
            XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
     &      PMC(I),1D0-EPS)
            YMIN=MAX(CKIN(71+2*I),EPS)
            YMAX=MIN(CKIN(72+2*I),1D0-EPS)
            IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
     &      (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
            XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
            THEMIN=MAX(CKIN(67+2*I),0D0)
            THEMAX=MIN(CKIN(68+2*I),PARU(1))
            IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
            Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
     &      ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
     &      2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
            Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
     &      ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
     &      2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
            IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
C...W limits when lepton on one side only.
            IF(MINT(143-I).EQ.0) THEN
              XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
              IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
     &        (CKIN(78)**2-PMS(3-I))/PMC(I))
            ENDIF
          ENDIF
  100   CONTINUE
 
C...W limits when lepton on both sides.
        IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
          IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
     &    (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
          IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
     &    (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
          IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
            XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
     &      PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
            XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
     &      PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
          ELSE
            XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
            XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
          ENDIF
        ENDIF
 
C...Q2 and W values and photon flux weight factors for initialization.
      ELSEIF(IGAGA.EQ.2) THEN
        ISUB=MINT(1)
        MINT(15)=0
        MINT(16)=0
 
C...W value for photon on one or both sides, and for processes
C...with gamma-gamma cross section peaked at small shat.
        IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
          VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
        ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
          VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
        ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
          VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
          IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
        ELSE
          VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
          IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
        ENDIF
        VINT(1)=SQRT(MAX(0D0,VINT(2)))
 
C...Upper estimate of photon flux weight factor.
C...Initialization Q2 scale. Flag incoming unresolved photon.
        WTGAGA=1D0
        DO 110 I=1,2
          IF(MINT(140+I).NE.0) THEN
            WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
     &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
            IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3) 
     &      THEN
              Q2INIT=5D0+Q2MIN(3-I)
            ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
              Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
            ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
              Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
            ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
     &      (ISUB.EQ.139.AND.I.EQ.1)) THEN
              Q2INIT=VINT(2)/3D0
            ELSEIF(ISUB.EQ.140) THEN
              Q2INIT=VINT(2)/2D0
            ELSE
              Q2INIT=Q2MIN(I)
            ENDIF
            VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
            IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140)) 
     &      MINT(14+I)=22
            VINT(306+I)=VINT(2+I)**2
          ENDIF
  110   CONTINUE
        VINT(320)=WTGAGA

C...Update pTmin and cross section information.
        IF(MSTP(82).LE.1) THEN
          PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
        ELSE
          PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
        ENDIF
        VINT(149)=4D0*PTMN**2/VINT(2)
        VINT(154)=PTMN 
        CALL PYXTOT
        VINT(318)=VINT(317)
 
C...Generate photons inside leptons and
C...calculate photon flux weight factors.
      ELSEIF(IGAGA.EQ.3) THEN
        ISUB=MINT(1)
        MINT(15)=0
        MINT(16)=0
 
C...Generate phase space point and check against cuts.
        LOOP=0
  120   LOOP=LOOP+1
        DO 130 I=1,2
          IF(MINT(140+I).NE.0) THEN
C...Pick x and Q2
            X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
            Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
C...Cuts on internal consistency in x and Q2.
            IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
            IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
     &      (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
C...Cuts on y and theta.
            Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
            IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
            RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
     &      ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
            THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
            IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
            IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
     &      GOTO 120
 
C...Phi angle isotropic. Reconstruct pT.
            PHI(I)=PARU(2)*PYR(0)
            PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
     &      PMS(I))*SIN(THETA(I))
 
C...Store info on variables selected, for documentation purposes.
            VINT(2+I)=-SQRT(Q2(I))
            VINT(304+I)=X(I)
            VINT(306+I)=Q2(I)
            VINT(308+I)=Y(I)
            VINT(310+I)=THETA(I)
            VINT(312+I)=PHI(I)
          ELSE
            VINT(304+I)=1D0
            VINT(306+I)=0D0
            VINT(308+I)=1D0
            VINT(310+I)=0D0
            VINT(312+I)=0D0
          ENDIF
  130   CONTINUE
 
C...Cut on W combines info from two sides.
        IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
          W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
     &    2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
     &    SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
     &    SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
          IF(W2.LT.W2MIN) GOTO 120
          IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
          PMS1=-Q2(1)
          PMS2=-Q2(2)
        ELSEIF(MINT(141).NE.0) THEN
          W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
          PMS1=-Q2(1)
          PMS2=PMS(2)
        ELSEIF(MINT(142).NE.0) THEN
          W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
          PMS1=PMS(1)
          PMS2=-Q2(2)
        ENDIF
 
C...Store kinematics info for photon(s) in subsystem cm frame.
        VINT(2)=W2
        VINT(1)=SQRT(W2)
        VINT(291)=0D0
        VINT(292)=0D0
        VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
        VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
        VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
        VINT(296)=0D0
        VINT(297)=0D0
        VINT(298)=-VINT(293)
        VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
        VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
 
C...Assign weight for photon flux; different for transverse and
C...longitudinal photons. Flag incoming unresolved photon.
        WTGAGA=1D0
        DO 140 I=1,2
          IF(MINT(140+I).NE.0) THEN
            WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
     &      LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
            IF(MSTP(16).EQ.0) THEN 
              XY=X(I)
            ELSE
              WTGAGA=WTGAGA*X(I)/Y(I)
              XY=Y(I)
            ENDIF
            IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
              WTGAGA=WTGAGA*(1D0-XY)
            ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
              WTGAGA=WTGAGA*(1D0-XY)
            ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
              WTGAGA=WTGAGA*(1D0-XY)
            ELSE
              WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
     &        PMS(I)*XY**2/Q2(I))
            ENDIF
            IF(MINT(106+I).EQ.0) MINT(14+I)=22  
          ENDIF
  140   CONTINUE
        VINT(319)=WTGAGA
        MINT(143)=LOOP

C...Update pTmin and cross section information.
        IF(MSTP(82).LE.1) THEN
          PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
        ELSE
          PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
        ENDIF
        VINT(149)=4D0*PTMN**2/VINT(2)
        VINT(154)=PTMN
        CALL PYXTOT
 
C...Reconstruct kinematics of photons inside leptons.
      ELSEIF(IGAGA.EQ.4) THEN
 
C...Make place for incoming particles and scattered leptons.
        MOVE=3
        IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
        MINT(4)=MINT(4)+MOVE
        DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
          IF(K(I,1).EQ.21) THEN
            DO 150 J=1,5
              K(I+MOVE,J)=K(I,J)
              P(I+MOVE,J)=P(I,J)
              V(I+MOVE,J)=V(I,J)
  150       CONTINUE
            IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
     &      K(I+MOVE,3)=K(I,3)+MOVE
            IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
     &      K(I+MOVE,4)=K(I,4)+MOVE
            IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
     &      K(I+MOVE,5)=K(I,5)+MOVE
          ENDIF
  160   CONTINUE
        DO 170 I=MINT(84)+1,N
          IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
     &    K(I,3)=K(I,3)+MOVE
  170   CONTINUE
 
C...Fill in incoming particles.
        DO 190 I=MINT(83)+1,MINT(83)+MOVE
          DO 180 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  180     CONTINUE
  190   CONTINUE
        DO 200 I=1,2
          K(MINT(83)+I,1)=21
          IF(MINT(140+I).NE.0) THEN
            K(MINT(83)+I,2)=MINT(140+I)
            P(MINT(83)+I,5)=VINT(302+I)
          ELSE
            K(MINT(83)+I,2)=MINT(10+I)
            P(MINT(83)+I,5)=VINT(2+I)
          ENDIF
          P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
     &    VINT(302))*(-1D0)**(I+1)
          P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
  200   CONTINUE
 
C...New mother-daughter relations in documentation section.
        IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
          K(MINT(83)+1,4)=MINT(83)+3
          K(MINT(83)+1,5)=MINT(83)+5
          K(MINT(83)+2,4)=MINT(83)+4
          K(MINT(83)+2,5)=MINT(83)+6
          K(MINT(83)+3,3)=MINT(83)+1
          K(MINT(83)+5,3)=MINT(83)+1
          K(MINT(83)+4,3)=MINT(83)+2
          K(MINT(83)+6,3)=MINT(83)+2
        ELSEIF(MINT(141).NE.0) THEN
          K(MINT(83)+1,4)=MINT(83)+3
          K(MINT(83)+1,5)=MINT(83)+4
          K(MINT(83)+2,4)=MINT(83)+5
          K(MINT(83)+3,3)=MINT(83)+1
          K(MINT(83)+4,3)=MINT(83)+1
          K(MINT(83)+5,3)=MINT(83)+2
        ELSEIF(MINT(142).NE.0) THEN
          K(MINT(83)+1,4)=MINT(83)+4
          K(MINT(83)+2,4)=MINT(83)+3
          K(MINT(83)+2,5)=MINT(83)+5
          K(MINT(83)+3,3)=MINT(83)+2
          K(MINT(83)+4,3)=MINT(83)+1
          K(MINT(83)+5,3)=MINT(83)+2
        ENDIF
 
C...Fill scattered lepton(s).
        DO 210 I=1,2
          IF(MINT(140+I).NE.0) THEN
            LSC=MINT(83)+MIN(I+2,MOVE)
            K(LSC,1)=21
            K(LSC,2)=MINT(140+I)
            P(LSC,1)=PT(I)*COS(PHI(I))
            P(LSC,2)=PT(I)*SIN(PHI(I))
            P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
            P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
     &      (-1D0)**(I-1)
            P(LSC,5)=VINT(302+I)
          ENDIF
  210   CONTINUE
 
C...Find incoming four-vectors to subprocess.
        K(N+1,1)=21
        IF(MINT(141).NE.0) THEN
          DO 220 J=1,4
            P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
  220     CONTINUE
        ELSE
          DO 230 J=1,4
            P(N+1,J)=P(MINT(83)+1,J)
  230     CONTINUE
        ENDIF
        K(N+2,1)=21
        IF(MINT(142).NE.0) THEN
          DO 240 J=1,4
            P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
  240     CONTINUE
        ELSE
          DO 250 J=1,4
            P(N+2,J)=P(MINT(83)+2,J)
  250     CONTINUE
        ENDIF
 
C...Define boost and rotation between hadronic subsystem and
C...collision rest frame; boost hadronic subsystem to this frame.
        DO 260 J=1,3
          BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
  260   CONTINUE
        CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
        BPHI=PYANGL(P(N+1,1),P(N+1,2))
        CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
        BTHETA=PYANGL(P(N+1,3),P(N+1,1))
        CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
     &  BETA(3))
 
C...Add on scattered leptons to final state.
        DO 280 I=1,2
          IF(MINT(140+I).NE.0) THEN
            LSC=MINT(83)+MIN(I+2,MOVE)
            N=N+1
            DO 270 J=1,5
              K(N,J)=K(LSC,J)
              P(N,J)=P(LSC,J)
              V(N,J)=V(LSC,J)
  270       CONTINUE
            K(N,1)=1
            K(N,3)=LSC
          ENDIF
  280   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRAND
C...Generates quantities characterizing the high-pT scattering at the
C...parton level according to the matrix elements. Chooses incoming,
C...reacting partons, their momentum fractions and one of the possible
C...subprocesses.
 
      SUBROUTINE PYRAND
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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
      VINT(157)=0D0
      VINT(158)=0D0
      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
      MINT(143)=1

C...Start by assuming incoming photon is entering subprocess.
      IF(MINT(11).EQ.22) THEN
         MINT(15)=22
         VINT(307)=VINT(3)**2
      ENDIF
      IF(MINT(12).EQ.22) THEN
         MINT(16)=22
         VINT(308)=VINT(4)**2
      ENDIF
      MINT(103)=MINT(11)
      MINT(104)=MINT(12)
 
C...Choice of process type - first event of pileup.
      INMULT=0 
      IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN
 
C...For gamma-p or gamma-gamma first pick between alternatives.
        IGA=0
        IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
        MINT(122)=IGA
 
C...For real gamma + gamma with different nature, flip at random.
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
     &  MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
          MINTSV=MINT(41)
          MINT(41)=MINT(42)
          MINT(42)=MINTSV
          MINTSV=MINT(45)
          MINT(45)=MINT(46)
          MINT(46)=MINTSV
          MINTSV=MINT(107)
          MINT(107)=MINT(108)
          MINT(108)=MINTSV
          IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
        ENDIF
 
C...Pick process type.
        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) INMULT=1
 
C...Choice of inclusive process type - pileup events.
      ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
        RSUB=VINT(131)*PYR(0)
        ISUB=96
        IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
     &  ISUB=91
        IF(ISUB.EQ.96) INMULT=1
      ENDIF
 
C...Choice of photon energy and flux factor inside lepton.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
        CALL PYGAGA(3,WTGAGA)
        IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
          CKIN(3)=MAX(VINT(285),VINT(154))
          CKIN(1)=2D0*CKIN(3)
        ENDIF
C...When necessary set direct/resolved photon by hand.
      ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
        IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
        IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
      ENDIF

C...Restrict direct*resolved processes to pTmin >= Q, 
C...to avoid doublecounting  with DIS.
      IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
        IF(MINT(15).EQ.22) THEN
          CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3))) 
        ELSE
          CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4))) 
        ENDIF 
        CKIN(1)=2D0*CKIN(3)        
      ENDIF

C...Set up for multiple interactions.
      IF(INMULT.EQ.1) CALL PYMULT(2)

C...Loopback point for minimum bias in photon physics.
      LOOP2=0
  125 LOOP2=LOOP2+1 
      IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
      IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
      IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
     &NGEN(97,1)=NGEN(97,1)+MINT(143)
      MINT(1)=ISUB
      ISTSB=ISET(ISUB)
 
C...Random choice of flavour for some SUSY processes.
      IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
C...~e_L ~nu_e or ~mu_L ~nu_mu.
        IF(ISUB.EQ.210) THEN
          KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)+1
C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
        ELSEIF(ISUB.EQ.213) THEN
          KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
        ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN
          IF(ISUB.GE.258) THEN
            RKF=4D0
          ELSE
            RKF=5D0
          ENDIF
          IF(MOD(ISUB,2).EQ.0) THEN
            KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
          ELSE
            KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
          ENDIF
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
          IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
            KSU1=KSUSY1
            KSU2=KSUSY1
          ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
            KSU1=KSUSY2
            KSU2=KSUSY2
          ELSEIF(PYR(0).LT.0.5D0) THEN
            KSU1=KSUSY1
            KSU2=KSUSY2
          ELSE
            KSU1=KSUSY2
            KSU2=KSUSY1
          ENDIF
          KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
C...~q ~q(bar);  ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
          KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
        ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
          KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
          IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
            KSU1=KSUSY1
            KSU2=KSUSY1
          ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
            KSU1=KSUSY2
            KSU2=KSUSY2
          ELSEIF(PYR(0).LT.0.5D0) THEN
            KSU1=KSUSY1
            KSU2=KSUSY2
          ELSE
            KSU1=KSUSY2
            KSU2=KSUSY1
          ENDIF
          IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
            RKF=5D0
          ELSE
            RKF=4D0
          ENDIF
          KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
        ENDIF
      ENDIF
 
C...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
      ELSEIF(ISUB.EQ.195) THEN
        KFR1=55
      ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
        KFR1=54
      ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
        KFR1=55
      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)
        IF(KFR1.EQ.54) THEN
          CALL PYTECM(S1,S2)
          TAUR1=S1/VINT(2)
        ENDIF
        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.OR.(ISUB.GE.364.AND.ISUB.LE.368))
     $THEN
        KFR2=23
        IF(ISUB.EQ.194) THEN
          KFR2=56
        ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
          KFR2=56
        ENDIF
        KCR2=PYCOMP(KFR2)
        TAUR2=PMAS(KCR2,1)**2/VINT(2)
        IF(KFR2.EQ.56) THEN
          CALL PYTECM(S1,S2)
          TAUR2=S2/VINT(2)
        ENDIF
        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.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
        IF(ISUB.EQ.352) VINT(204)=PMAS(63,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.3.OR.MINT(123).EQ.7)) THEN
        VRN=PYR(0)*SIGT(0,0,5)
        IF(MINT(101).LE.1) THEN
          I1MN=0
          I1MX=0
        ELSE
          I1MN=1
          I1MX=MINT(101)
        ENDIF
        IF(MINT(102).LE.1) THEN
          I2MN=0
          I2MX=0
        ELSE
          I2MN=1
          I2MX=MINT(102)
        ENDIF
        DO 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
        VINT(67)=PMM(1)
        VINT(68)=PMM(2)

C...Select mass for GVMD states (rejecting previous assignment).
        Q0S=4D0*PARP(15)**2
        Q1S=4D0*VINT(154)**2
        LOOP3=0
  202   LOOP3=LOOP3+1
        DO 208 JT=1,2
          IF(MINT(106+JT).EQ.3) THEN 
            PS=VINT(2+JT)**2
            PMM(JT)=(Q0S+PS)*(Q1S+PS)/
     &      (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
            IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
     &      PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
          ENDIF
  208   CONTINUE
        IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
          IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3)) 
     &    GOTO 202
          GOTO 100
        ENDIF
 
C...Side/sides of diffractive system.
        MINT(17)=0
        MINT(18)=0
        IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
        IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
 
C...Find masses of particles and minimal masses of diffractive states.
        DO 210 JT=1,2
          PDIF(JT)=PMM(JT)
          VINT(68+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.
        LOOP3=0
  220   LOOP3=LOOP3+1
        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)) THEN
          IF(LOOP3.LT.100) GOTO 220
          GOTO 100
        ENDIF
        IF(ISUB.EQ.92) THEN
          FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
          IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 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
        VINT(283)=PMM(1)**2/4D0
        VINT(284)=PMM(2)**2/4D0
 
C...Note: in the following, by In is meant the integral over the
C...quantity multiplying coefficient cn.
C...Choose tau according to h1(tau)/tau, where
C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
C...I1/I5*c5*1/(tau+tau_R') +
C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
C...I1/I7*c7*tau/(1.-tau), and
C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
      ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
        CALL PYKLIM(1)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        RTAU=PYR(0)
        MTAU=1
        IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
     &  MTAU=5
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
     &  COEF(ISUB,5)) MTAU=6
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
     &  COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
        CALL PYKMAP(1,MTAU,PYR(0))
 
C...2 -> 3, 4 processes:
C...Choose tau' according to h4(tau,tau')/tau', where
C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
          CALL PYKLIM(4)
          IF(MINT(51).NE.0) THEN
            IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
            IF(MFAIL.EQ.1) THEN
              MSTI(61)=1
              RETURN
            ENDIF
            GOTO 100
          ENDIF
          RTAUP=PYR(0)
          MTAUP=1
          IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
          IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
          CALL PYKMAP(4,MTAUP,PYR(0))
        ENDIF
 
C...Choose y* according to h2(y*), where
C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
C...and c1 + c2 + c3 + c4 + c5 = 1.
        CALL PYKLIM(2)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        RYST=PYR(0)
        MYST=1
        IF(RYST.GT.COEF(ISUB,8)) MYST=2
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
     &  COEF(ISUB,11)) MYST=5
        CALL PYKMAP(2,MYST,PYR(0))
 
C...2 -> 2 processes:
C...Choose cos(theta-hat) (cth) according to h3(cth), where
C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
C...and c0 + c1 + c2 + c3 + c4 = 1.
        CALL PYKLIM(3)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
          RCTH=PYR(0)
          MCTH=1
          IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
     &    COEF(ISUB,16)) MCTH=5
          CALL PYKMAP(3,MCTH,PYR(0))
        ENDIF
 
C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
        IF(ISTSB.EQ.5) THEN
          CALL PYKMAP(5,0,0D0)
          IF(MINT(51).NE.0) THEN
            IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
            IF(MFAIL.EQ.1) THEN
              MSTI(61)=1
              RETURN
            ENDIF
            GOTO 100
          ENDIF
        ENDIF

C...DIS as f + gamma* -> f process: set dummy values.
      ELSEIF(ISTSB.EQ.8) THEN  
        VINT(21)=0.9D0
        VINT(22)=0D0
        VINT(23)=0D0 
        VINT(47)=0D0
        VINT(48)=0D0         
 
C...Low-pT or multiple interactions (first semihard interaction).
      ELSEIF(ISTSB.EQ.9) THEN
        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(2)
          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)
            VINT(120)=VINT(2+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)*VINT(315)*VINT(316)
 
C...Multiply cross section by lepton -> photon flux factor.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
        SIGS=WTGAGA*SIGS
        DO 270 ICHN=1,NCHN
          SIGH(ICHN)=WTGAGA*SIGH(ICHN)
  270   CONTINUE
        SIGLPT=WTGAGA*SIGLPT
      ENDIF
 
C...Multiply cross-section by user-defined weights.
      IF(MSTP(173).EQ.1) THEN
        SIGS=PARP(173)*SIGS
        DO 280 ICHN=1,NCHN
          SIGH(ICHN)=PARP(173)*SIGH(ICHN)
  280   CONTINUE
        SIGLPT=PARP(173)*SIGLPT
      ENDIF
      WTXS=1D0
      SIGSWT=SIGS
      VINT(99)=1D0
      VINT(100)=1D0
      IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
        IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
     &  MSUB(95).EQ.0) CALL PYEVWT(WTXS)
        SIGSWT=WTXS*SIGS
        VINT(99)=WTXS
        IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
      ENDIF
 
C...Calculations for Monte Carlo estimate of all cross-sections.
      IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
        IF(MSTP(142).LE.1) THEN
          XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
        ELSE
          XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
        ENDIF
      ELSEIF(MINT(82).EQ.1) THEN
        XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
      ENDIF
      IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
     &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
 
C...Multiple interactions: store results of cross-section calculation.
      IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
        VINT(153)=SIGSOR
        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.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
        IF(VIOL.LT.PYR(0)) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
          GOTO 100
        ENDIF
      ELSEIF(MFAIL.EQ.0) THEN
        RATND=SIGLPT/XSEC(95,1)
        IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          ISUB=0
          GOTO 100
        ENDIF
        VIOL=VIOL/RATND
        IF(VIOL.LT.PYR(0)) THEN
          GOTO 125
        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)+MINT(143)
        IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
      ENDIF
      IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
 
C...Choose flavour of reacting partons (and subprocess).
      IF(ISTSB.GE.11) GOTO 300
      RSIGS=SIGS*PYR(0)
      QT2=VINT(48)
      RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
     &(VINT(1)/PARP(89))**PARP(90))**2))**2)
      IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
     &PYR(0).GT.RQQBAR)) THEN
        DO 290 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 300
  290   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.
  300 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 330 JT=1,2
        MINT(18+JT)=0
        VINT(154+JT)=0D0
        MSPLI=0
        IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
        IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
        IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
        IF(MSPLI.EQ.2) THEN
          KFLH=MINT(14+JT)
          XHRD=VINT(140+JT)
          Q2HRD=VINT(54)
          MINT(105)=MINT(102+JT)
          MINT(109)=MINT(106+JT)
          VINT(120)=VINT(2+JT)
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
          ELSE
            CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
          ENDIF
          WTMX=4D0*XPQ(KFLH)
          IF(MSTP(13).EQ.2) THEN
            Q2PMS=Q2HRD/PMAS(11,1)**2
            WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
          ENDIF
  310     XE=XHRD**PYR(0)
          XG=MIN(1D0-1D-10,XHRD/XE)
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(22,XG,Q2HRD,XPQ)
          ELSE
            CALL PYPDFL(22,XG,Q2HRD,XPQ)
          ENDIF
          WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
          IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
          IF(WT.LT.PYR(0)*WTMX) GOTO 310
          MINT(18+JT)=1
          VINT(154+JT)=XE
          DO 320 KFLS=-25,25
            XSFX(JT,KFLS)=XPQ(KFLS)
  320     CONTINUE
        ENDIF
  330 CONTINUE
 
C...Pick scale where photon is resolved.
      Q0S=PARP(15)**2
      Q1S=VINT(154)**2
      VINT(283)=0D0
      IF(MINT(107).EQ.3) THEN
        IF(MSTP(66).EQ.1) THEN
          VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
        ELSEIF(MSTP(66).EQ.2) THEN
          PS=VINT(3)**2
          Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
          Q2INT=SQRT(Q0S*Q2EFF)
          VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
        ELSEIF(MSTP(66).EQ.3) THEN
          VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
        ELSEIF(MSTP(66).GE.4) THEN
          PS=0.25D0*VINT(3)**2
          VINT(283)=(Q0S+PS)*(Q1S+PS)/
     &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
        ENDIF
      ENDIF 
      VINT(284)=0D0
      IF(MINT(108).EQ.3) THEN
        IF(MSTP(66).EQ.1) THEN
          VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
        ELSEIF(MSTP(66).EQ.2) THEN
          PS=VINT(4)**2
          Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
          Q2INT=SQRT(Q0S*Q2EFF)
          VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
        ELSEIF(MSTP(66).EQ.3) THEN
          VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
        ELSEIF(MSTP(66).GE.4) THEN
          PS=0.25D0*VINT(4)**2
          VINT(284)=(Q0S+PS)*(Q1S+PS)/
     &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
        ENDIF
      ENDIF
      IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
 
C...Format statements for differential cross-section maximum violations.
 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
     &'in event',1X,I7,'D0'/1X,'Execution stopped!')
 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
     &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
     &'in event',1X,I7)
 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
     &'in event',1X,I7,'D0'/1X,'Execution stopped!')
 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
     &'in event',1X,I7)
 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSCAT
C...Finds outgoing flavours and event type; sets up the kinematics
C...and colour flow of the hard scattering
 
      SUBROUTINE PYSCAT
 
C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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.OR.
     &(ISUB.GE.135.AND.ISUB.LE.140)) THEN
        IGLGA=21
        IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
        CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
  180   RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
        DO 190 I=1,MDCY(IGLGA,3)
          KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
          RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
          IF(RKFL.LE.0D0) GOTO 200
  190   CONTINUE
  200   CONTINUE
        IF(ISUB.EQ.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.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
          IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
        ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
          IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
        ENDIF
      ENDIF
 
C...Final state flavours and colour flow: default values
      JS=1
      MINT(21)=MINT(15)
      MINT(22)=MINT(16)
      MINT(23)=0
      MINT(24)=0
      KCC=20
      KCS=ISIGN(1,MINT(15))
 
      IF(ISET(ISUB).EQ.11) THEN
C...User-defined processes: find products
        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.1D-8) GOTO 220
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
          CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
          Z(3-JT)=1D0-XH/(1D0-Z(JT))
          SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 220
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
          CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
          PHIR=PARU(2)*PYR(0)
          CPHI=COS(PHIR)
          ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
     &    SQRT(1D0-CTHE(2)**2)*CPHI
          Z1=2D0-Z(JT)
          Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
          Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
          Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &    PMQ(3-JT)**2/SHP))
          ZMIN=2D0*PMQ(3-JT)/SHPR
          ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
          KCC=22
          KFRES=25
 
        ELSEIF(ISUB.EQ.6) THEN
C...Z0 + W+/- -> W+/-
 
        ELSEIF(ISUB.EQ.7) THEN
C...W+ + W- -> Z0
 
        ELSEIF(ISUB.EQ.8) THEN
C...W+ + W- -> h0
          XH=SH/SHP
  230     DO 260 JT=1,2
            I=MINT(14+JT)
            IA=IABS(I)
            IF(IA.LE.10) THEN
              RVCKM=VINT(180+I)*PYR(0)
              DO 240 J=1,MSTP(1)
                IB=2*J-1+MOD(IA,2)
                IPM=(5-ISIGN(1,I))/2
                IDC=J+MDCY(IA,2)+2
                IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
                MINT(20+JT)=ISIGN(IB,I)
                RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
                IF(RVCKM.LE.0D0) GOTO 250
  240         CONTINUE
            ELSE
              IB=2*((IA+1)/2)-1+MOD(IA,2)
              MINT(20+JT)=ISIGN(IB,I)
            ENDIF
  250       PMQ(JT)=PYMASS(MINT(20+JT))
  260     CONTINUE
          JT=INT(1.5D0+PYR(0))
          ZMIN=2D0*PMQ(JT)/SHPR
          ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
     &    (SHPR*(SHPR-PMQ(3-JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(ZMIN.GE.ZMAX) GOTO 230
          Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
          IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
     &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
          SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 230
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
          CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
          Z(3-JT)=1D0-XH/(1D0-Z(JT))
          SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 230
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
          CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
          PHIR=PARU(2)*PYR(0)
          CPHI=COS(PHIR)
          ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
     &    SQRT(1D0-CTHE(2)**2)*CPHI
          Z1=2D0-Z(JT)
          Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
          Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
          Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &    PMQ(3-JT)**2/SHP))
          ZMIN=2D0*PMQ(3-JT)/SHPR
          ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
          KCC=22
          KFRES=25
 
        ELSEIF(ISUB.EQ.10) THEN
C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
          IF(MINT(2).EQ.1) THEN
            KCC=22
          ELSE
C...W exchange: need to mix flavours according to CKM matrix
            DO 280 JT=1,2
              I=MINT(14+JT)
              IA=IABS(I)
              IF(IA.LE.10) THEN
                RVCKM=VINT(180+I)*PYR(0)
                DO 270 J=1,MSTP(1)
                  IB=2*J-1+MOD(IA,2)
                  IPM=(5-ISIGN(1,I))/2
                  IDC=J+MDCY(IA,2)+2
                  IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
                  MINT(20+JT)=ISIGN(IB,I)
                  RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
                  IF(RVCKM.LE.0D0) GOTO 280
  270           CONTINUE
              ELSE
                IB=2*((IA+1)/2)-1+MOD(IA,2)
                MINT(20+JT)=ISIGN(IB,I)
              ENDIF
  280       CONTINUE
            KCC=22
          ENDIF
        ENDIF
 
      ELSEIF(ISUB.LE.20) THEN
        IF(ISUB.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
          MINT(21)=ISIGN(KFLF,MINT(15))
          MINT(22)=-MINT(21)
          KCC=4
 
        ELSEIF(ISUB.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
          MINT(21)=21
          MINT(22)=21
          KCC=MINT(2)+4
 
        ELSEIF(ISUB.EQ.14) THEN
C...f + fbar -> g + gamma; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=22
          KCC=17+JS
 
        ELSEIF(ISUB.EQ.15) THEN
C...f + fbar -> g + Z0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=23
          KCC=17+JS
 
        ELSEIF(ISUB.EQ.16) THEN
C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=ISIGN(24,KCH1+KCH2)
          KCC=17+JS
 
        ELSEIF(ISUB.EQ.17) THEN
C...f + fbar -> g + h0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=25
          KCC=17+JS
 
        ELSEIF(ISUB.EQ.18) THEN
C...f + fbar -> gamma + gamma; th arbitrary
          MINT(21)=22
          MINT(22)=22
 
        ELSEIF(ISUB.EQ.19) THEN
C...f + fbar -> gamma + Z0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=22
          MINT(23-JS)=23
 
        ELSEIF(ISUB.EQ.20) THEN
C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
C...(p(fbar')-p(W+))**2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
          MINT(20+JS)=22
          MINT(23-JS)=ISIGN(24,KCH1+KCH2)
        ENDIF
 
      ELSEIF(ISUB.LE.30) THEN
        IF(ISUB.EQ.21) THEN
C...f + fbar -> gamma + h0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=22
          MINT(23-JS)=25
 
        ELSEIF(ISUB.EQ.22) THEN
C...f + fbar -> Z0 + Z0; th arbitrary
          MINT(21)=23
          MINT(22)=23
 
        ELSEIF(ISUB.EQ.23) THEN
C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
          MINT(20+JS)=23
          MINT(23-JS)=ISIGN(24,KCH1+KCH2)
 
        ELSEIF(ISUB.EQ.24) THEN
C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=23
          MINT(23-JS)=KFHIGG
 
        ELSEIF(ISUB.EQ.25) THEN
C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
          MINT(21)=-ISIGN(24,MINT(15))
          MINT(22)=-MINT(21)
 
        ELSEIF(ISUB.EQ.26) THEN
C...f + fbar' -> W+/- + h0 (or H0, or A0);
C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
          MINT(20+JS)=ISIGN(24,KCH1+KCH2)
          MINT(23-JS)=KFHIGG
 
        ELSEIF(ISUB.EQ.27) THEN
C...f + fbar -> h0 + h0
 
        ELSEIF(ISUB.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
          KCC=MINT(2)+6
          IF(MINT(15).EQ.21) KCC=KCC+2
          IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
          IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
 
        ELSEIF(ISUB.EQ.29) THEN
C...f + g -> f + gamma; th = (p(f)-p(f))**2
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=22
          KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.30) THEN
C...f + g -> f + Z0; th = (p(f)-p(f))**2
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=23
          KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
        ENDIF
 
      ELSEIF(ISUB.LE.40) THEN
        IF(ISUB.EQ.31) THEN
C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
          IF(MINT(15).EQ.21) JS=2
          I=MINT(14+JS)
          IA=IABS(I)
          MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
          RVCKM=VINT(180+I)*PYR(0)
          DO 290 J=1,MSTP(1)
            IB=2*J-1+MOD(IA,2)
            IPM=(5-ISIGN(1,I))/2
            IDC=J+MDCY(IA,2)+2
            IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
            MINT(20+JS)=ISIGN(IB,I)
            RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
            IF(RVCKM.LE.0D0) GOTO 300
  290     CONTINUE
  300     KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.32) THEN
C...f + g -> f + h0; th = (p(f)-p(f))**2
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=25
          KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.33) THEN
C...f + gamma -> f + g; th=(p(f)-p(f))**2
          IF(MINT(15).EQ.22) JS=2
          MINT(23-JS)=21
          KCC=24+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.34) THEN
C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
          IF(MINT(15).EQ.22) JS=2
          KCC=22
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.35) THEN
C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
          IF(MINT(15).EQ.22) JS=2
          MINT(23-JS)=23
          KCC=22
 
        ELSEIF(ISUB.EQ.36) THEN
C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
          IF(MINT(15).EQ.22) JS=2
          I=MINT(14+JS)
          IA=IABS(I)
          MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
          IF(IA.LE.10) THEN
            RVCKM=VINT(180+I)*PYR(0)
            DO 310 J=1,MSTP(1)
              IB=2*J-1+MOD(IA,2)
              IPM=(5-ISIGN(1,I))/2
              IDC=J+MDCY(IA,2)+2
              IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
              MINT(20+JS)=ISIGN(IB,I)
              RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
              IF(RVCKM.LE.0D0) GOTO 320
  310       CONTINUE
          ELSE
            IB=2*((IA+1)/2)-1+MOD(IA,2)
            MINT(20+JS)=ISIGN(IB,I)
          ENDIF
  320     KCC=22
 
        ELSEIF(ISUB.EQ.37) THEN
C...f + gamma -> f + h0
 
        ELSEIF(ISUB.EQ.38) THEN
C...f + Z0 -> f + g
 
        ELSEIF(ISUB.EQ.39) THEN
C...f + Z0 -> f + gamma
 
        ELSEIF(ISUB.EQ.40) THEN
C...f + Z0 -> f + Z0
        ENDIF
 
      ELSEIF(ISUB.LE.50) THEN
        IF(ISUB.EQ.41) THEN
C...f + Z0 -> f' + W+/-
 
        ELSEIF(ISUB.EQ.42) THEN
C...f + Z0 -> f + h0
 
        ELSEIF(ISUB.EQ.43) THEN
C...f + W+/- -> f' + g
 
        ELSEIF(ISUB.EQ.44) THEN
C...f + W+/- -> f' + gamma
 
        ELSEIF(ISUB.EQ.45) THEN
C...f + W+/- -> f' + Z0
 
        ELSEIF(ISUB.EQ.46) THEN
C...f + W+/- -> f' + W+/-
 
        ELSEIF(ISUB.EQ.47) THEN
C...f + W+/- -> f' + h0
 
        ELSEIF(ISUB.EQ.48) THEN
C...f + h0 -> f + g
 
        ELSEIF(ISUB.EQ.49) THEN
C...f + h0 -> f + gamma
 
        ELSEIF(ISUB.EQ.50) THEN
C...f + h0 -> f + Z0
        ENDIF
 
      ELSEIF(ISUB.LE.60) THEN
        IF(ISUB.EQ.51) THEN
C...f + h0 -> f' + W+/-
 
        ELSEIF(ISUB.EQ.52) THEN
C...f + h0 -> f + h0
 
        ELSEIF(ISUB.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.54) THEN
C...g + gamma -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=27
          IF(MINT(16).EQ.21) KCC=28
 
        ELSEIF(ISUB.EQ.55) THEN
C...g + Z0 -> f + fbar
 
        ELSEIF(ISUB.EQ.56) THEN
C...g + W+/- -> f + fbar'
 
        ELSEIF(ISUB.EQ.57) THEN
C...g + h0 -> f + fbar
 
        ELSEIF(ISUB.EQ.58) THEN
C...gamma + gamma -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=21
 
        ELSEIF(ISUB.EQ.59) THEN
C...gamma + Z0 -> f + fbar
 
        ELSEIF(ISUB.EQ.60) THEN
C...gamma + W+/- -> f + fbar'
        ENDIF
 
      ELSEIF(ISUB.LE.70) THEN
        IF(ISUB.EQ.61) THEN
C...gamma + h0 -> f + fbar
 
        ELSEIF(ISUB.EQ.62) THEN
C...Z0 + Z0 -> f + fbar
 
        ELSEIF(ISUB.EQ.63) THEN
C...Z0 + W+/- -> f + fbar'
 
        ELSEIF(ISUB.EQ.64) THEN
C...Z0 + h0 -> f + fbar
 
        ELSEIF(ISUB.EQ.65) THEN
C...W+ + W- -> f + fbar
 
        ELSEIF(ISUB.EQ.66) THEN
C...W+/- + h0 -> f + fbar'
 
        ELSEIF(ISUB.EQ.67) THEN
C...h0 + h0 -> f + fbar
 
        ELSEIF(ISUB.EQ.68) THEN
C...g + g -> g + g; th arbitrary
          KCC=MINT(2)+12
          KCS=(-1)**INT(1.5D0+PYR(0))
 
        ELSEIF(ISUB.EQ.69) THEN
C...gamma + gamma -> W+ + W-; th arbitrary
          MINT(21)=24
          MINT(22)=-24
          KCC=21
 
        ELSEIF(ISUB.EQ.70) THEN
C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
          IF(MINT(15).EQ.22) MINT(21)=23
          IF(MINT(16).EQ.22) MINT(22)=23
          KCC=21
        ENDIF
 
      ELSEIF(ISUB.LE.80) THEN
        IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
          XH=SH/SHP
          MINT(21)=MINT(15)
          MINT(22)=MINT(16)
          PMQ(1)=PYMASS(MINT(21))
          PMQ(2)=PYMASS(MINT(22))
  330     JT=INT(1.5D0+PYR(0))
          ZMIN=2D0*PMQ(JT)/SHPR
          ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
     &    (SHPR*(SHPR-PMQ(3-JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
          IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
     &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
          SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 330
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
          CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
          Z(3-JT)=1D0-XH/(1D0-Z(JT))
          SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 330
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
          CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
          PHIR=PARU(2)*PYR(0)
          CPHI=COS(PHIR)
          ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
     &    SQRT(1D0-CTHE(2)**2)*CPHI
          Z1=2D0-Z(JT)
          Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
          Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
          Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &    PMQ(3-JT)**2/SHP))
          ZMIN=2D0*PMQ(3-JT)/SHPR
          ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
          KCC=22
 
        ELSEIF(ISUB.EQ.73) THEN
C...Z0 + W+/- -> Z0 + W+/-
          JS=MINT(2)
          XH=SH/SHP
  340     JT=3-MINT(2)
          I=MINT(14+JT)
          IA=IABS(I)
          IF(IA.LE.10) THEN
            RVCKM=VINT(180+I)*PYR(0)
            DO 350 J=1,MSTP(1)
              IB=2*J-1+MOD(IA,2)
              IPM=(5-ISIGN(1,I))/2
              IDC=J+MDCY(IA,2)+2
              IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
              MINT(20+JT)=ISIGN(IB,I)
              RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
              IF(RVCKM.LE.0D0) GOTO 360
  350       CONTINUE
          ELSE
            IB=2*((IA+1)/2)-1+MOD(IA,2)
            MINT(20+JT)=ISIGN(IB,I)
          ENDIF
  360     PMQ(JT)=PYMASS(MINT(20+JT))
          MINT(23-JT)=MINT(17-JT)
          PMQ(3-JT)=PYMASS(MINT(23-JT))
          JT=INT(1.5D0+PYR(0))
          ZMIN=2D0*PMQ(JT)/SHPR
          ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
     &    (SHPR*(SHPR-PMQ(3-JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(ZMIN.GE.ZMAX) GOTO 340
          Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
          IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
     &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
          SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 340
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
          CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
          Z(3-JT)=1D0-XH/(1D0-Z(JT))
          SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 340
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
          CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
          PHIR=PARU(2)*PYR(0)
          CPHI=COS(PHIR)
          ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
     &    SQRT(1D0-CTHE(2)**2)*CPHI
          Z1=2D0-Z(JT)
          Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
          Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
          Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &    PMQ(3-JT)**2/SHP))
          ZMIN=2D0*PMQ(3-JT)/SHPR
          ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
          KCC=22
 
        ELSEIF(ISUB.EQ.74) THEN
C...Z0 + h0 -> Z0 + h0
 
        ELSEIF(ISUB.EQ.75) THEN
C...W+ + W- -> gamma + gamma
 
        ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
          XH=SH/SHP
  370     DO 400 JT=1,2
            I=MINT(14+JT)
            IA=IABS(I)
            IF(IA.LE.10) THEN
              RVCKM=VINT(180+I)*PYR(0)
              DO 380 J=1,MSTP(1)
                IB=2*J-1+MOD(IA,2)
                IPM=(5-ISIGN(1,I))/2
                IDC=J+MDCY(IA,2)+2
                IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
                MINT(20+JT)=ISIGN(IB,I)
                RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
                IF(RVCKM.LE.0D0) GOTO 390
  380         CONTINUE
            ELSE
              IB=2*((IA+1)/2)-1+MOD(IA,2)
              MINT(20+JT)=ISIGN(IB,I)
            ENDIF
  390       PMQ(JT)=PYMASS(MINT(20+JT))
  400     CONTINUE
          JT=INT(1.5D0+PYR(0))
          ZMIN=2D0*PMQ(JT)/SHPR
          ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
     &    (SHPR*(SHPR-PMQ(3-JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(ZMIN.GE.ZMAX) GOTO 370
          Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
          IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
     &    (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
          SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 370
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
          CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
          Z(3-JT)=1D0-XH/(1D0-Z(JT))
          SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
          IF(SQC1.LT.1D-8) GOTO 370
          C1=SQRT(SQC1)
          C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
          CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
          CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
          PHIR=PARU(2)*PYR(0)
          CPHI=COS(PHIR)
          ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
     &    SQRT(1D0-CTHE(2)**2)*CPHI
          Z1=2D0-Z(JT)
          Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
          Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
          Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
     &    PMQ(3-JT)**2/SHP))
          ZMIN=2D0*PMQ(3-JT)/SHPR
          ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
          ZMAX=MIN(1D0-XH,ZMAX)
          IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
          KCC=22
 
        ELSEIF(ISUB.EQ.78) THEN
C...W+/- + h0 -> W+/- + h0
 
        ELSEIF(ISUB.EQ.79) THEN
C...h0 + h0 -> h0 + h0
 
        ELSEIF(ISUB.EQ.80) THEN
C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
          IF(MINT(15).EQ.22) JS=2
          I=MINT(14+JS)
          IA=IABS(I)
          MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
          IB=3-IA
          MINT(20+JS)=ISIGN(IB,I)
          KCC=22
        ENDIF
 
      ELSEIF(ISUB.LE.90) THEN
        IF(ISUB.EQ.81) THEN
C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
          MINT(21)=ISIGN(MINT(55),MINT(15))
          MINT(22)=-MINT(21)
          KCC=4
 
        ELSEIF(ISUB.EQ.82) THEN
C...g + g -> Q + Qbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(MINT(55),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.83) THEN
C...f + q -> f' + Q; th = (p(f) - p(f'))**2
          KFOLD=MINT(16)
          IF(MINT(2).EQ.2) KFOLD=MINT(15)
          KFAOLD=IABS(KFOLD)
          IF(KFAOLD.GT.10) THEN
            KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
          ELSE
            RCKM=VINT(180+KFOLD)*PYR(0)
            IPM=(5-ISIGN(1,KFOLD))/2
            KFANEW=-MOD(KFAOLD+1,2)
  410       KFANEW=KFANEW+2
            IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
            IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
              IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
     &        VCKM(KFAOLD/2,(KFANEW+1)/2)
              IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
     &        VCKM(KFANEW/2,(KFAOLD+1)/2)
            ENDIF
            IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
          ENDIF
          IF(MINT(2).EQ.1) THEN
            MINT(21)=ISIGN(MINT(55),MINT(15))
            MINT(22)=ISIGN(KFANEW,MINT(16))
          ELSE
            MINT(21)=ISIGN(KFANEW,MINT(15))
            MINT(22)=ISIGN(MINT(55),MINT(16))
            JS=2
          ENDIF
          KCC=22
 
        ELSEIF(ISUB.EQ.84) THEN
C...g + gamma -> Q + Qbar; th arbitary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(MINT(55),KCS)
          MINT(22)=-MINT(21)
          KCC=27
          IF(MINT(16).EQ.21) KCC=28
 
        ELSEIF(ISUB.EQ.85) THEN
C...gamma + gamma -> F + Fbar; th arbitary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(MINT(56),KCS)
          MINT(22)=-MINT(21)
          KCC=21
 
        ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
          KCC=24
          KCS=(-1)**INT(1.5D0+PYR(0))
        ENDIF
 
      ELSEIF(ISUB.LE.100) THEN
        IF(ISUB.EQ.95) THEN
C...Low-pT ( = energyless g + g -> g + g)
          KCC=MINT(2)+12
          KCS=(-1)**INT(1.5D0+PYR(0))
 
        ELSEIF(ISUB.EQ.96) THEN
C...Multiple interactions (should be reassigned to QCD process)
        ENDIF
 
      ELSEIF(ISUB.LE.110) THEN
        IF(ISUB.EQ.101) THEN
C...g + g -> gamma*/Z0
          KCC=21
          KFRES=22
 
        ELSEIF(ISUB.EQ.102) THEN
C...g + g -> h0 (or H0, or A0)
          KCC=21
          KFRES=KFHIGG
 
        ELSEIF(ISUB.EQ.103) THEN
C...gamma + gamma -> h0 (or H0, or A0)
          KCC=21
          KFRES=KFHIGG
 
        ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
C...g + g -> chi_0c or chi_2c.
          KCC=21
          KFRES=KFPR(ISUB,1)
 
        ELSEIF(ISUB.EQ.106) THEN
C...g + g -> J/Psi + gamma
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
          KCC=21
 
        ELSEIF(ISUB.EQ.107) THEN
C...g + gamma -> J/Psi + g
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
          KCC=22
          IF(MINT(16).EQ.22) KCC=33
 
        ELSEIF(ISUB.EQ.108) THEN
C...gamma + gamma -> J/Psi + gamma
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
 
        ELSEIF(ISUB.EQ.110) THEN
C...f + fbar -> gamma + h0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=22
          MINT(23-JS)=KFHIGG
        ENDIF
 
      ELSEIF(ISUB.LE.120) THEN
        IF(ISUB.EQ.111) THEN
C...f + fbar -> g + h0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=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.OR.ISUB.EQ.132) THEN
C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
          IF(MINT(15).EQ.22) JS=2
          MINT(23-JS)=21
          KCC=24+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
          IF(MINT(15).EQ.22) JS=2
          KCC=22
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
C...g + gamma*_(T,L) -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=27
          IF(MINT(16).EQ.21) KCC=28
 
        ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=21
 
        ENDIF
 
      ELSEIF(ISUB.LE.160) THEN
        IF(ISUB.EQ.141) THEN
C...f + fbar -> gamma*/Z0/Z'0
          KFRES=32
 
        ELSEIF(ISUB.EQ.142) THEN
C...f + fbar' -> W'+/-
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          KFRES=ISIGN(34,KCH1+KCH2)
 
        ELSEIF(ISUB.EQ.143) THEN
C...f + fbar' -> H+/-
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          KFRES=ISIGN(37,KCH1+KCH2)
 
        ELSEIF(ISUB.EQ.144) THEN
C...f + fbar' -> R
          KFRES=ISIGN(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.146) THEN
C...e + gamma -> e* (excited lepton)
          IF(MINT(15).EQ.22) JS=2
          KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
          KCC=22
 
        ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
C...q + g -> q* (excited quark)
          IF(MINT(15).EQ.21) JS=2
          KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
          KCC=30+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.149) THEN
C...g + g -> eta_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.169) THEN
C...q + qbar -> e + e* (excited lepton)
          KFQSTR=KFPR(ISUB,2)
          KFQEXC=MOD(KFQSTR,KEXCIT)
          JS=MINT(2)
          MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
          MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
 
        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)

        ELSEIF(ISUB.EQ.195) THEN
C...f + fbar' -> f'' + fbar''' via s-channel
C...rho_tech+ th=(p(f)-p(f'))**2
C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
          IF(MOD(MINT(15),2).EQ.0) THEN
            MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
            MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
          ELSE
            MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
            MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
          ENDIF
        ENDIF
 
CMRENNA++
      ELSEIF(ISUB.LE.215) THEN
        IF(ISUB.EQ.201) THEN
C...f + fbar -> ~e_L + ~e_Lbar
          MINT(21)=ISIGN(KSUSY1+11,KCS)
          MINT(22)=-MINT(21)
 
        ELSEIF(ISUB.EQ.202) THEN
C...f + fbar -> ~e_R + ~e_Rbar
          MINT(21)=ISIGN(KSUSY2+11,KCS)
          MINT(22)=-MINT(21)
 
        ELSEIF(ISUB.EQ.203) THEN
C...f + fbar -> ~e_R + ~e_Lbar
          KCSG=1
          IF(MINT(2).EQ.2) KCSG=-1
          MINT(21)=ISIGN(KSUSY1+11,KCSG)
          MINT(22)=-ISIGN(KSUSY2+11,KCSG)
 
        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
          KCSG=1
          IF(MINT(2).EQ.2) KCSG=-1
          MINT(21)=ISIGN(KSUSY1+13,KCSG)
          MINT(22)=-ISIGN(KSUSY2+13,KCSG)
 
        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
          KCSG=1
          IF(MINT(2).EQ.2) KCSG=-1
          MINT(21)=ISIGN(KSUSY1+15,KCSG)
          MINT(22)=-ISIGN(KSUSY2+15,KCSG)
 
        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
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          MINT(21)=ISIGN(KSUSY1+24,KCH1)
          MINT(22)=-MINT(21)
 
        ELSEIF(ISUB.EQ.227) THEN
C...f + fbar -> ~chi+-2 + ~chi-+2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          MINT(21)=ISIGN(KSUSY1+37,KCH1)
          MINT(22)=-MINT(21)
 
        ELSEIF(ISUB.EQ.228) THEN
C...f + fbar -> ~chi+-1 + ~chi-+2
C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
C...js=1 if pyr<.5, js=2 if pyr>.5
C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
C          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
          ISGN=1
          IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
          MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
C...Correct color combination
          IF(MINT(43).EQ.4) KCC=4
 
        ELSEIF(ISUB.EQ.262) THEN
C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
          ISGN=1
          IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
          MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
C...Correct color combination
          IF(MINT(43).EQ.4) KCC=4
 
        ELSEIF(ISUB.EQ.263) THEN
C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
          IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
     &    (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
            MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
            MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
          ELSE
            JS=2
            MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
            MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
          ENDIF
C...Correct color combination
          IF(MINT(43).EQ.4) KCC=4
 
        ELSEIF(ISUB.EQ.264) THEN
C...g + g -> ~t_1 + ~t_1bar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.265) THEN
C...g + g -> ~t_2 + ~t_2bar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
        ENDIF
 
      ELSEIF(ISUB.LE.296) THEN
        IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
C...qi + qj -> ~qi_L + ~qj_L
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
          MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
          MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
 
        ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
C...qi + qj -> ~qi_R + ~qj_R
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
          MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
          MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
 
        ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
C...qi + qj -> ~qi_L + ~qj_R
          MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
          MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
          MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
          MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
          MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
          MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
          MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
          MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
          ISGN=1
          IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
          MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          IF(MINT(43).EQ.4) KCC=4
 
        ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
          ISGN=1
          IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
          MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          IF(MINT(43).EQ.4) KCC=4
 
        ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
C...pure LL + RR
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.294) THEN
C...qj + g -> ~qj_L + ~g
          IF(MINT(15).EQ.21) JS=2
          I=MINT(14+JS)
          IA=IABS(I)
          MINT(20+JS)=ISIGN(KSUSY1+IA,I)
          MINT(23-JS)=KSUSY1+21
          KCC=MINT(2)+6
          IF(JS.EQ.2) KCC=KCC+2
          KCS=ISIGN(1,I)
 
        ELSEIF(ISUB.EQ.295) THEN
C...qj + g -> ~qj_R + ~g
          IF(MINT(15).EQ.21) JS=2
          I=MINT(14+JS)
          IA=IABS(I)
          MINT(20+JS)=ISIGN(KSUSY2+IA,I)
          MINT(23-JS)=KSUSY1+21
          KCC=MINT(2)+6
          IF(JS.EQ.2) KCC=KCC+2
          KCS=ISIGN(1,I)
        ENDIF

      ELSEIF(ISUB.LE.340) THEN

        IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
C...q + qbar' -> H+ + H0
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
          MINT(20+JS)=ISIGN(37,KCH1+KCH2)
          MINT(23-JS)=KFPR(ISUB,2)
        ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
C...f + fbar -> A0 + H0; th arbitrary
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=KFPR(ISUB,1)
          MINT(23-JS)=KFPR(ISUB,2)
        ELSEIF(ISUB.EQ.301) THEN
C...f + fbar -> H+ H-
          MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
          MINT(22)=-MINT(21)
        ENDIF
CMRENNA--

      ELSEIF(ISUB.LE.360) THEN

        IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
C...l + l -> H_L++/--, H_R++/--
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
 
        ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
          IF(MINT(15).EQ.22) JS=2
          MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
          MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
          KCC=22
 
        ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
          MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
          MINT(22)=-MINT(21)

        ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- 
C...as inner process).
          DO 432 JT=1,2
            I=MINT(14+JT)
            IA=IABS(I)
            IF(IA.LE.10) THEN
              RVCKM=VINT(180+I)*PYR(0)
              DO 422 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 422
                MINT(20+JT)=ISIGN(IB,I)
                RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
                IF(RVCKM.LE.0D0) GOTO 432
  422         CONTINUE
            ELSE
              IB=2*((IA+1)/2)-1+MOD(IA,2)
              MINT(20+JT)=ISIGN(IB,I)
            ENDIF
  432     CONTINUE
          KCC=22
          KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
          IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES

        ENDIF

      ELSEIF(ISUB.LE.380) THEN
        IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
C...f + fbar -> pi+ pi-
          KSW=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
          MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
C...f + fbar -> neutral neutral
        ELSEIF(ISUB.LE.367) THEN
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
C...f + fbar' -> charged neutral
        ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
          IN=1
          IC=2
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
c         MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
c         MINT(23-JS)=KFPR(ISUB,IN)
          MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
          MINT(20+JS)=KFPR(ISUB,IN)

        ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
          IN=2
          IC=1
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
          MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
          MINT(23-JS)=KFPR(ISUB,IN)
        ENDIF
      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(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
            P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
          ELSE
            P(I,5)=PYMASS(K(I,2))
          ENDIF
          IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
     &    P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
  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)
      IMPLICIT INTEGER(I-N)
      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=MIN(VINT(2),PARP(67)*VINT(56))
      MECOR=0
      IF(MSTP(68).EQ.1.AND.(ISUB.EQ.1.OR.ISUB.EQ.2.OR.
     &ISUB.EQ.141.OR.ISUB.EQ.142.OR.ISUB.EQ.144)) MECOR=1      
      FCQ2MX=1D0
 
C...Initialize QCD evolution and check phase space.
      Q2MNC=PARP(62)**2
      Q2MNCS(1)=Q2MNC
      Q2MNCS(2)=Q2MNC
      IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
        Q0S=PARP(15)**2
        PS=VINT(3)**2
        Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
        Q2INT=SQRT(Q0S*Q2EFF)
        Q2MNCS(1)=MAX(Q2MNC,Q2INT)
      ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
        Q2MNCS(1)=MAX(Q2MNC,VINT(283))
      ENDIF 
      IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
        Q0S=PARP(15)**2
        PS=VINT(4)**2
        Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &  EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
        Q2INT=SQRT(Q0S*Q2EFF)
        Q2MNCS(2)=MAX(Q2MNC,Q2INT)
      ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
        Q2MNCS(2)=MAX(Q2MNC,VINT(284))
      ENDIF
      MCEV=0
      ALAMS=PARU(112)
      PARU(112)=PARP(61)
      FQ2C=1D0
      TCMX=0D0
      IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
        MCEV=1
        IF(MSTP(64).EQ.1) FQ2C=PARP(63)
        IF(MSTP(64).EQ.2) FQ2C=PARP(64)
        TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
        IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
     &  MCEV=0
      ENDIF
 
C...Initialize QED evolution and check phase space.
      MEEV=0
      XEE=1D-10
      SPME=PMAS(11,1)**2
      IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
     &SPME=PMAS(13,1)**2
      IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
     &SPME=PMAS(15,1)**2
      Q2MNE=MAX(PARP(68)**2,2D0*SPME)
      TEMX=0D0
      FWTE=10D0
      IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
        MEEV=1
        TEMX=LOG(Q2MX/SPME)
        IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
      ENDIF
      IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
 
C...Loopback point in case of failure to reconstruct kinematics.  
      NS=N
      LOOP=0
  100 LOOP=LOOP+1
      IF(LOOP.GT.100) THEN
        MINT(51)=1
        RETURN
      ENDIF
      N=NS

C...Initial values: flavours, momenta, virtualities.
      DO 120 JT=1,2
        MORE(JT)=1
        KFBEAM(JT)=MINT(10+JT)
        IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
        KFLS(JT)=MINT(14+JT)
        KFLS(JT+2)=KFLS(JT)
        XS(JT)=VINT(40+JT)
        IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
        ZS(JT)=1D0
        Q2S(JT)=FCQ2MX*Q2MX
        TEVCSV(JT)=TCMX
        ALAM(JT)=PARP(61)
        THE2(JT)=1D0
        TEVESV(JT)=TEMX
        DO 110 KFL=-25,25
          XFS(JT,KFL)=XSFX(JT,KFL)
  110   CONTINUE
C...Special kinematics check for c/b quarks (that g -> c cbar or
C...b bbar kinematically possible).
      KFLCB=IABS(KFLS(JT))
      IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
        IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
          MINT(51)=1
          RETURN
        ENDIF
      ENDIF 
  120 CONTINUE
      DSH=VINT(44)
      IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
 
C...Find if interference with final state partons.
      MFIS=0
      IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
      IF(MFIS.NE.0) THEN
        DO 140 I=1,2
          KCFI(I)=0
          KCA=PYCOMP(IABS(KFLS(I)))
          IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
          NFIS(I)=0
          IF(KCFI(I).NE.0) THEN
            IF(I.EQ.1) IPFS=IPUS1
            IF(I.EQ.2) IPFS=IPUS2
            DO 130 J=1,2
              ICSI=MOD(K(IPFS,3+J),MSTU(5))
              IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
     &        (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
                NFIS(I)=NFIS(I)+1
                THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
     &          P(ICSI,2)**2))
                IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
              ENDIF
  130       CONTINUE
          ENDIF
  140   CONTINUE
        IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
      ENDIF
 
C...Pick up leg with highest virtuality.
  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(PARP(65)*DSHR/VINT(2),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))
        IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) 
     &  WTAPC(21)=3D0*WTAPC(21)
C...f -> f, gamma -> f.
      ELSEIF(IABS(KFLB).LE.20) THEN
        WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
        WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
        WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
        IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
        IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) 
     &  WTAPE(22)=3D0*WTAPE(22)
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))
C...Ensure that Q2 is above threshold for charm/bottom.
      KFLCB=IABS(KFLB) 
      IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
     &MCEV.EQ.1) THEN
        IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
          Q2CB=1.1*PMAS(KFLCB,1)**2 
          TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
          FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
        ENDIF
      ENDIF
      MCE=0
      IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
      ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
        IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
      ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
        IF(Q2EB.GT.Q2MNE) MCE=2
      ELSEIF(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
      ENDIF 

C...Remove kinematically impossible branchings.
      UHAT=Q2B-DSH*(1D0-Z)/Z
      IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 210

C...Matrix-element corrections for s-channel resonance production.
      IF(MECOR.EQ.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
        SHAT=DSH/Z
        THAT=-Q2B
        IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
          RMEPS=(THAT**2+UHAT**2+2D0*DSH*SHAT)/(SHAT**2+DSH**2)
          WTZ=WTZ*RMEPS
        ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
          RMEPS=(SHAT**2+UHAT**2+2D0*DSH*THAT)/((SHAT-DSH)**2+DSH**2)
          WTZ=WTZ*RMEPS/3D0
        ENDIF 
      ENDIF
 
C...Impose angular constraint in first branching from interference
C...with final state partons.
      IF(MCE.EQ.1) THEN
        IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
          THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
          IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
            IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 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)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(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)
      VINT(120)=VINT(2+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
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
        K(IT,1)=3
        IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
     &  IABS(K(IT,2)).EQ.22) K(IT,1)=1
        P(IT,5)=PYMASS(K(IT,2))
        IF(DMSMA.LE.P(IT,5)**2) GOTO 100
        IF(MSTP(63).GE.1.AND.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.AND.NTRY2.LT.200) 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
      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)
      IMPLICIT INTEGER(I-N)
      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),
     &VDCY(4)
      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)
          JTMAX=1
        ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
          IREF(1,1)=MINT(84)+1+ISET(ISUB)
          IREF(1,2)=MINT(84)+2+ISET(ISUB)
          IREF(1,4)=MINT(83)+5+ISET(ISUB)
          IREF(1,5)=MINT(83)+6+ISET(ISUB)
          JTMAX=2
        ELSEIF(ISET(ISUB).EQ.5) THEN
          IREF(1,1)=MINT(84)+3
          IREF(1,2)=MINT(84)+4
          IREF(1,3)=MINT(84)+5
          IREF(1,4)=MINT(83)+7
          IREF(1,5)=MINT(83)+8
          IREF(1,6)=MINT(83)+9
          JTMAX=3
        ENDIF
 
C...Define original resonance for odd cases.
      ELSE
        ISUB=0
        IREF(1,1)=IRES
        JTMAX=1
      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.....Set decay vertex for initial resonances
      DO 140 JT=1,JTMAX
        DO 130 I=1,4
          V(IREF(1,JT),I)=0D0
  130   CONTINUE
  140 CONTINUE
 
C...Loop over decay history.
      NP=1
      IP=0
  150 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.
  160 N=NSAV
      DO 250 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 240
        KFA=IABS(K(ID,2))
        KCA=PYCOMP(KFA)
        IF(MWID(KCA).EQ.0) GOTO 240
        IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240
        IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
     &  KFA.EQ.18) IT4=IT4+1
        K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
        K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
 
C...Choose lifetime and determine decay vertex.
        IF(K(ID,1).EQ.5) THEN
          V(ID,5)=0D0
        ELSEIF(K(ID,1).NE.4) THEN
          V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
        ENDIF
        DO 170 J=1,4
          VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
  170   CONTINUE
 
C...Determine whether decay allowed or not.
        MOUT=0
        IF(MSTJ(22).EQ.2) THEN
          IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
        ELSEIF(MSTJ(22).EQ.3) THEN
          IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
        ELSEIF(MSTJ(22).EQ.4) THEN
          IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
          IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
        ENDIF
        IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
          K(ID,1)=4
          GOTO 240
        ENDIF
 
C...Info for selection of decay channel: sign, pairings.
        IF(KCHG(KCA,3).EQ.0) THEN
          IPM=2
        ELSE
          IPM=(5-ISIGN(1,K(ID,2)))/2
        ENDIF
        KFB=0
        IF(JTMAX.EQ.2) THEN
          KFB=IABS(K(IREF(IP,3-JT),2))
        ELSEIF(JTMAX.EQ.3) THEN
          JT2=JT+1-3*(JT/3)
          KFB=IABS(K(IREF(IP,JT2),2))
          IF(KFB.NE.KFA) THEN
            JT2=JT+2-3*((JT+1)/3)
            KFB=IABS(K(IREF(IP,JT2),2))
          ENDIF
        ENDIF
 
C...Select decay channel.
        IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
     &  ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
        CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
        WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
        IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
        IF(WDTE0S.LE.0D0) GOTO 240
        RKFL=WDTE0S*PYR(0)
        IDL=0
  180   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 180
 
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)
        JTZ=JT   
 
C...Select masses; to begin with assume resonances narrow.
        DO 200 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 200
            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 190 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
  190       CONTINUE
CMRENNA--
          ELSEIF(KFLW.EQ.6) THEN
            PMMN(I)=PMAS(24,1)+PMAS(5,1)
          ENDIF
  200   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).GT.P(ID,5)) THEN
            CALL PYERRM(13,'(PYRESD:) daughter masses too large')
            MINT(51)=1
            RETURN
          ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
            CALL PYERRM(3,'(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
  210       LOOP=LOOP+1
            P(N+IWID3,5)=PYMASS(KFLW3)
            IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210
            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 (plus special case top).
        IF(KFL3(JT).NE.0) THEN
          DO 230 I=N+1,N+3
            DO 220 J=1,5
              K(I,J)=0
C              V(I,J)=0D0
  220       CONTINUE
  230     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 for t -> W + b + Z.
          IF(KFA.EQ.6) THEN
            K(N+2,1)=3
            ISID=4
            IF(KCQM(JT).EQ.-1) ISID=5
            IDAU=N+2
            K(ID,ISID)=K(ID,ISID)+IDAU
            K(IDAU,ISID)=MSTU(5)*ID
 
C...Set colour flow in three-body decays - programmed as special cases.
          ELSEIF(KFC2A.LE.6) THEN
            K(N+2,1)=3
            K(N+3,1)=3
            ISID=4
            IF(KFL2(JT).LT.0) ISID=5
            K(N+2,ISID)=MSTU(5)*(N+3)
            K(N+3,9-ISID)=MSTU(5)*(N+2)
          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
  240   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
  250 CONTINUE
 
C...Check for allowed combinations. Skip if no decays.
      IF(JTMAX.EQ.1) THEN
        IF(KDCY(1).EQ.0) GOTO 620
      ELSEIF(JTMAX.EQ.2) THEN
        IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620
        IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
        IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
      ELSEIF(JTMAX.EQ.3) THEN
        IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620
        IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160
        IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
        IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160
        IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160
        IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
        IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160
      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),CHIZ,THEZ,PHIZ)
          IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
          CTHE(1)=COS(THEZ)
          CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
          CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
        ENDIF
 
C...Boost partons to Z0 rest frame.
        CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
     &  P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
 
C...Mark decayed resonance and add documentation lines,
        K(ID,1)=K(ID,1)+10
        IDOC=MINT(83)+MINT(4)
        DO 270 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 260 J=1,5
              P(I1,J)=P(I,J)
  260       CONTINUE
          ENDIF
  270   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 610
      ENDIF
 
C...Order incoming partons and outgoing resonances.
      IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
     &NINH.EQ.0) THEN
        ILIN(1)=MINT(84)+1
        IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
        IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22) 
     &  ILIN(1)=2*MINT(84)+3-ILIN(1)
        ILIN(2)=2*MINT(84)+3-ILIN(1)
        IMIN=1
        IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
     &  .EQ.36) IMIN=3
        IMAX=2
        IORD=1
        IF(K(IREF(IP,1),2).EQ.23) IORD=2
        IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
        IAKIPD=IABS(K(IREF(IP,IORD),2))
        IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
        IF(KDCY(IORD).EQ.0) IORD=3-IORD
 
C...Order decay products of resonances.
        DO 280 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
  280   CONTINUE
 
C...Find charge, isospin, left- and righthanded couplings.
        DO 300 I=IMIN,IMAX
          DO 290 J=1,4
            COUP(I,J)=0D0
  290     CONTINUE
          KFA=IABS(K(ILIN(I),2))
          IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300
          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)
  300   CONTINUE
 
C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
        IF(ISUB.EQ.22) THEN
          DO 330 I=3,5,2
            I1=IORD
            IF(I.EQ.5) I1=3-IORD
            DO 320 J1=1,2
              DO 310 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
  310         CONTINUE
  320       CONTINUE
  330     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 160
        ENDIF
      ENDIF
 
C...Select angular orientation type - Z'/W' only.
      MZPWP=0
      IF(ISUB.EQ.141) THEN
        IF(PYR(0).LT.PARU(130)) MZPWP=1
        IF(IP.EQ.2) THEN
          IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
          IAKIR=IABS(K(IREF(2,2),2))
          IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
          IF(IAKIR.LE.20) MZPWP=2
        ENDIF
        IF(IP.GE.3) MZPWP=2
      ELSEIF(ISUB.EQ.142) THEN
        IF(PYR(0).LT.PARU(136)) MZPWP=1
        IF(IP.EQ.2) THEN
          IAKIR=IABS(K(IREF(2,2),2))
          IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
          IF(IAKIR.LE.20) MZPWP=2
        ENDIF
        IF(IP.GE.3) MZPWP=2
      ENDIF
 
C...Select random angles (begin of weighting procedure).
  340 DO 350 JT=1,JTMAX
        IF(KDCY(JT).EQ.0) GOTO 350
        IF(JTMAX.EQ.1.AND.ISUB.NE.0) THEN
          CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
          IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
          PHI(JT)=VINT(24)
        ELSE
          CTHE(JT)=2D0*PYR(0)-1D0
          PHI(JT)=PARU(2)*PYR(0)
        ENDIF
  350 CONTINUE
 
      IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
C...Construct massless four-vectors.
        DO 370 I=N+1,N+4
          K(I,1)=1
          DO 360 J=1,5
            P(I,J)=0D0
C            V(I,J)=0D0
  360     CONTINUE
  370   CONTINUE
        DO 380 JT=1,JTMAX
          IF(KDCY(JT).EQ.0) GOTO 380
          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))
  380   CONTINUE
 
C...Store incoming and outgoing momenta, with random rotation to
C...avoid accidental zeroes in HA expressions.
        IF(ISUB.NE.0) THEN 
          DO 400 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 390 J=1,3
              P(N+4+I,J)=P(ILIN(I),J)
  390       CONTINUE
  400     CONTINUE
  410     THERR=ACOS(2D0*PYR(0)-1D0)
          PHIRR=PARU(2)*PYR(0)
          CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
          DO 430 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 410
            DO 420 J=1,4
              PK(I,J)=P(N+4+I,J)
  420       CONTINUE
  430     CONTINUE
        ENDIF
 
C...Calculate internal products.
        IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
     &  ISUB.EQ.142) THEN
          DO 450 I1=IMIN,IMAX-1
            DO 440 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)
  440       CONTINUE
  450     CONTINUE
        ENDIF

C...Calculate four-products.
        IF(ISUB.NE.0) THEN
          DO 470 I=1,2
            DO 460 J=1,4
              PK(I,J)=-PK(I,J)
  460       CONTINUE
  470     CONTINUE
          DO 490 I1=IMIN,IMAX-1
            DO 480 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)
  480       CONTINUE
  490     CONTINUE
        ENDIF
      ENDIF
 
      KFAGM=IABS(IREF(IP,7))
      IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
C...Isotropic decay selected by user.
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(JTMAX.EQ.3) THEN
C...Isotropic decay when three mother particles.
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(IT4.GE.1) THEN
C... Isotropic decay t -> b + W etc for 4th generation q and l.
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
     &  IREF(IP,7).EQ.36) THEN
C...Angular weight for h0 -> 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=2D0*(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(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
     &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
        CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
     &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
        CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
     &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
        CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
     &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
        WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
     &  (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
        WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
     &  ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
 
      ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
C...-> gluon/gamma + 2 quarks/leptons.
        WT=PKK(1,3)**2+PKK(2,4)**2
        WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
 
      ELSEIF(ISUB.EQ.22) THEN
C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
        S34=P(IREF(IP,IORD),5)**2
        S56=P(IREF(IP,3-IORD),5)**2
        TI=PKK(1,3)+PKK(1,4)+S34
        UI=PKK(1,5)+PKK(1,6)+S56
        TIR=REAL(TI)
        UIR=REAL(UI)
        FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
        FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
        FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
        FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
        FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
        FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
        FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
        FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
        WT=
     &  CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
     &  CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
     &  CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
     &  CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
        WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
     &  (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
     &  ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
     &  1D0/UI**2))
 
      ELSEIF(ISUB.EQ.23) THEN
C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
        D34=P(IREF(IP,IORD),5)**2
        D56=P(IREF(IP,3-IORD),5)**2
        DT=PKK(1,3)+PKK(1,4)+D34
        DU=PKK(1,5)+PKK(1,6)+D56
        FACBW=1D0/((SH-SQMW)**2+GMMW**2)
        CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
        CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
        FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
     &  REAL(CBWZ)*FGK(1,2,5,6,3,4))
        FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
     &  REAL(CBWZ)*FGK(1,2,6,5,3,4))
        WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
        WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
     &  DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
 
      ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
C...(or H0, or A0).
        WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
     &  PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
     &  COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
        WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
     &  (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
 
      ELSEIF(ISUB.EQ.25) THEN
C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
        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(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
     &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
        CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
     &  COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
        CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
     &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
        CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
     &  COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
     &  COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
        IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
     &  PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
        IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
     &  PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
        WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
     &  ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
 
      ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
        IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
        IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
        WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
 
      ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
     &  ISUB.EQ.77) THEN
C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
        WT=16D0*PKK(3,5)*PKK(4,6)
        WTMAX=SH**2
 
      ELSEIF(ISUB.EQ.110) THEN
C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(ISUB.EQ.141) THEN
        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
          IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
            VPI=PARU(119+2*KFAIC)
            API=PARU(120+2*KFAIC)
          ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
            VPI=PARJ(178+2*KFAIC)
            API=PARJ(179+2*KFAIC)
          ELSE
            VPI=PARJ(186+2*KFAIC)
            API=PARJ(187+2*KFAIC)
          ENDIF
C...Couplings of final flavour.
          KFAF=IABS(KFL1(1))
          EF=KCHG(KFAF,1)/3D0
          AF=SIGN(1D0,EF+0.1D0)
          VF=AF-4D0*EF*XWV
          KFAFC=1
          IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
          IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
          IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
          IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
            VPF=PARU(119+2*KFAFC)
            APF=PARU(120+2*KFAFC)
          ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
            VPF=PARJ(178+2*KFAFC)
            APF=PARJ(179+2*KFAFC)
          ELSE
            VPF=PARJ(186+2*KFAFC)
            APF=PARJ(187+2*KFAFC)
          ENDIF
C...Asymmetry and weight.
          ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
     &    4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
     &    (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
     &    (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
     &    EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
     &    (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
     &    (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
          WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
          WTMAX=2D0+ABS(ASYM)
        ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W-.
          RM1=P(NSD(1)+1,5)**2/SH
          RM2=P(NSD(1)+2,5)**2/SH
          CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
     &    (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
          CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
     &    (RM2-RM1)**2)
          WT=CFLAT+CCOS2*CTHE(1)**2
          WTMAX=CFLAT+MAX(0D0,CCOS2)
        ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
     &    IABS(KFL1(1)).EQ.37)) THEN
C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
          WT=1D0-CTHE(1)**2
          WTMAX=1D0
        ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
C...Angular weight for f + fbar -> Z' -> Z0 + h0.
          RM1=P(NSD(1)+1,5)**2/SH
          RM2=P(NSD(1)+2,5)**2/SH
          FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
          WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
          WTMAX=1D0+FLAM2/(8D0*RM1)
        ELSEIF(MZPWP.EQ.0) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
C...(W:s like if intermediate Z).
          D34=P(IREF(IP,IORD),5)**2
          D56=P(IREF(IP,3-IORD),5)**2
          DT=PKK(1,3)+PKK(1,4)+D34
          DU=PKK(1,5)+PKK(1,6)+D56
          FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
          FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
          WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
          WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
     &    (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
        ELSEIF(MZPWP.EQ.1) THEN
C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
C...(W:s approximately longitudinal, like if intermediate H).
          WT=16D0*PKK(3,5)*PKK(4,6)
          WTMAX=SH**2
        ELSE
C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
          WT=1D0
          WTMAX=1D0
        ENDIF
 
      ELSEIF(ISUB.EQ.142) THEN
        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, 
C...t + bbar -> t + W + bbar. 
          WT=1D0
          WTMAX=1D0
        ENDIF
 
      ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
     &  THEN
C...Isotropic decay of leptoquarks (assumed spin 0).
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
        SIDE=1D0
        IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
        IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
          WT=1D0+SIDE*CTHE(1)
          WTMAX=2D0
        ELSEIF(IP.EQ.1) THEN
          RM1=P(NSD(1)+1,5)**2/SH
          WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
          WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
        ELSE
C...W/Z decay assumed isotropic, since not known.
          WT=1D0
          WTMAX=1D0
        ENDIF
 
      ELSEIF(ISUB.EQ.149) THEN
C...Isotropic decay of techni-eta.
        WT=1D0
        WTMAX=1D0
 
      ELSEIF(ISUB.EQ.191) THEN
        IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
C...Angular weight for f + fbar -> rho_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 340
 
C...Construct massive four-vectors using angles chosen.
  500 DO 600 JT=1,JTMAX
        IF(KDCY(JT).EQ.0) GOTO 600
        ID=IREF(IP,JT)
        DO 510 J=1,5
          DPMO(J)=P(ID,J)
  510   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))
          N0=NSD(JT)+2
        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))
          N0=NSD(JT)+3
        ENDIF
 
        DO 520 J=1,4
          VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
  520   CONTINUE
C...Fill in position of decay vertex.
        DO 540 I=NSD(JT)+1,N0
          DO 530 J=1,4
            V(I,J)=VDCY(J)
  530     CONTINUE
          V(I,5)=0D0
  540   CONTINUE
CMRENNA--
 
C...Mark decayed resonances; trace history.
        K(ID,1)=K(ID,1)+10
        KFA=IABS(K(ID,2))
        KCA=PYCOMP(KFA)
        IF(KCQM(JT).NE.0) THEN
C...Do not kill colour flow through coloured resonance!
        ELSE
          K(ID,4)=NSD(JT)+1
          K(ID,5)=NSD(JT)+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 560 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 550 J=1,5
                P(I1,J)=P(I,J)
  550         CONTINUE
            ENDIF
  560     CONTINUE
        ELSE
          K(NSD(JT)+1,3)=ID
          K(NSD(JT)+2,3)=ID
          IF(KFL3(JT).NE.0) K(NSD(JT)+3,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 570 I=NSHBEF+1,NSHAFT
              IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
  570       CONTINUE
          ENDIF
          IF(K(NSD2,1).GT.10) THEN
            DO 580 I=NSHBEF+1,NSHAFT
              IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
     &        I.NE.NSD1) NSD2=I
  580       CONTINUE
          ENDIF
          IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
            DO 590 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
  590       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)
  600 CONTINUE
 
C...Fill information for 2 -> 1 -> 2.
  610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
        MINT(7)=MINT(83)+6+2*ISET(ISUB)
        MINT(8)=MINT(83)+7+2*ISET(ISUB)
        MINT(25)=KFL1(1)
        MINT(26)=KFL2(1)
        VINT(23)=CTHE(1)
        RM3=P(N-1,5)**2/SH
        RM4=P(N,5)**2/SH
        BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
        VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
        VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
        VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
        VINT(47)=SQRT(VINT(48))
      ENDIF
 
C...Possibility of colour rearrangement in W+W- events.
      IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
        IAKF1=IABS(KFL1(1))
        IAKF2=IABS(KFL1(2))
        IAKF3=IABS(KFL2(1))
        IAKF4=IABS(KFL2(2))
        IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
     &  MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
     &  PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
      ENDIF
 
C...Loop back if needed.
  620 IF(IP.LT.NP) GOTO 150
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMULT
C...Initializes treatment of multiple interactions, selects kinematics
C...of hardest interaction if low-pT physics included in run, and
C...generates all non-hardest interactions.
 
      SUBROUTINE PYMULT(MMUL)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
          PARP(82)=0.9D0*PARP(82)
          VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
     &    VINT(2)
          GOTO 100
        ENDIF
        IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) 
     &  PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
 
C...Start iteration to find k factor.
        YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
        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
          SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
     &    VINT(317)/(VINT(318)*VINT(320))
          XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
        ELSEIF(MSTP(82).EQ.2) THEN
          XT2=1D0
          XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
     &    VINT(149)*(1D0+VINT(149))
        ELSE
          XC2=4D0*CKIN(3)**2/VINT(2)
          IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
        ENDIF
 
      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
        ISUB=MINT(1)
  145   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/MAX(1D-10,SIGT(0,0,5))))
        IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
     &  ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
     &  .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
          IF(VINT(150).LT.PYR(0)) GOTO 145
          VINT(150)=1D0
        ENDIF 
 
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
        VINT(151)=0D0
        VINT(152)=0D0
 
C...Reconstruct strings in hard scattering.
        NMAX=MINT(84)+4
        IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
        IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
        NSTR=0
        DO 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.
        IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
     &  ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
     &  ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
     &  ISUBSV.NE.96)) THEN
          XT2=(1D0-VINT(141))*(1D0-VINT(142))
        ELSE
          XT2=VINT(25)
          IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
          IF(ISET(ISUBSV).EQ.2)
     &    XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
          IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
        ENDIF 
        IF(MSTP(82).LE.1) THEN
          SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
          IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
     &    VINT(317)/(VINT(318)*VINT(320))
          XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
        ELSE
          XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
     &    MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
        ENDIF
        VINT(63)=0D0
        VINT(64)=0D0
        VINT(143)=1D0-VINT(141)
        VINT(144)=1D0-VINT(142)
 
C...Iterate downwards in xT2.
  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(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
        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)
      IMPLICIT INTEGER(I-N)
      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
            PTA=SQRT(VINT(282+JT))
            PTB=0D0
            IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
              PTB=PARP(99)*SQRT(-LOG(PYR(0)))
            ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
              RPT1=PYR(0)
              RPT2=PYR(0)
              PTB=-PARP(99)*LOG(RPT1*RPT2)
            ENDIF
            IF(PTB.GT.PARP(100)) GOTO 120
            PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
            PT=PT*0.8D0**MINT(57)
            IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
          ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
            IF(MSTP(93).LE.0) THEN
              PT=0D0
            ELSEIF(MSTP(93).EQ.1) THEN
              PT=PARP(99)*SQRT(-LOG(PYR(0)))
            ELSEIF(MSTP(93).EQ.2) THEN
              RPT1=PYR(0)
              RPT2=PYR(0)
              PT=-PARP(99)*LOG(RPT1*RPT2)
            ELSEIF(MSTP(93).EQ.3) THEN
              HA=PARP(99)**2
              HB=PARP(100)**2
              PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
            ELSE
              HA=PARP(99)**2
              HB=PARP(100)**2
              IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
              PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
            ENDIF
            IF(PT.GT.PARP(100)) GOTO 120
          ELSE
            PT=0D0
          ENDIF
          VINT(156+JT)=PT
          PHI=PARU(2)*PYR(0)
          P(I,1)=PT*COS(PHI)
          P(I,2)=PT*SIN(PHI)
          PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
        ENDIF
  130 CONTINUE
      IF(MINT(47).EQ.1) RETURN
 
C...Kinematics construction for initial partons.
      I1=MINT(83)+3
      I2=MINT(83)+4
      IF(ISUB.EQ.95) THEN
        SHS=0D0
        SHR=0D0
      ELSE
        SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
     &  (P(I1,2)+P(I2,2))**2
        SHR=SQRT(MAX(0D0,SHS))
        IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
        P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
        P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
        P(I2,4)=SHR-P(I1,4)
        P(I2,3)=-P(I1,3)
 
C...Transform partons to overall CM-frame.
        ROBO(3)=(P(I1,1)+P(I2,1))/SHR
        ROBO(4)=(P(I1,2)+P(I2,2))/SHR
        CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
        ROBO(2)=PYANGL(P(I1,1),P(I1,2))
        CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
        ROBO(1)=PYANGL(P(I1,3),P(I1,1))
        CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
        CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
        ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
        CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
      ENDIF
 
C...Optionally fix up x and Q2 definitions for leptoproduction.
      IDISXQ=0
      IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
     &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
      IF(IDISXQ.EQ.1) THEN
 
C...Find where incoming and outgoing leptons/partons are sitting.
        LESD=1
        IF(MINT(42).EQ.1) LESD=2
        LPIN=MINT(83)+3-LESD
        LEIN=MINT(84)+LESD
        LQIN=MINT(84)+3-LESD
        LEOUT=MINT(84)+2+LESD
        LQOUT=MINT(84)+5-LESD
        IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
        IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
        LSCMS=0
        DO 140 I=MINT(84)+5,N
          IF(K(I,2).EQ.94) THEN
            LSCMS=I
            LEOUT=I+LESD
            LQOUT=I+3-LESD
          ENDIF
  140   CONTINUE
        LQBG=IPU1
        IF(LESD.EQ.1) LQBG=IPU2
 
C...Calculate actual and wanted momentum transfer.
        XNOM=VINT(43-LESD)
        Q2NOM=-VINT(45)
        HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
     &  P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
     &  (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
        HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
        FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
        P(N+1,1)=FAC*P(LEOUT,1)
        P(N+1,2)=FAC*P(LEOUT,2)
        P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
     &  Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
        P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
     &  P(N+1,3)**2)
        DO 150 J=1,4
          QOLD(J)=P(LEIN,J)-P(LEOUT,J)
          QNEW(J)=P(LEIN,J)-P(N+1,J)
  150   CONTINUE
 
C...Boost outgoing electron and daughters.
        IF(LSCMS.EQ.0) THEN
          DO 160 J=1,4
            P(LEOUT,J)=P(N+1,J)
  160     CONTINUE
        ELSE
          DO 170 J=1,3
            P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
  170     CONTINUE
          PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
          DO 180 J=1,3
            DBE(J)=PINV*P(N+2,J)
  180     CONTINUE
          DO 200 I=LSCMS+1,N
            IORIG=I
  190       IORIG=K(IORIG,3)
            IF(IORIG.GT.LEOUT) GOTO 190
            IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
     &      CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
  200     CONTINUE
        ENDIF
 
C...Copy shower initiator and all outgoing partons.
        NCOP=N+1
        K(NCOP,3)=LQBG
        DO 210 J=1,5
          P(NCOP,J)=P(LQBG,J)
  210   CONTINUE
        DO 240 I=MINT(84)+1,N
          ICOP=0
          IF(K(I,1).GT.10) GOTO 240
          IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
            ICOP=I
          ELSE
            IORIG=I
  220       IORIG=K(IORIG,3)
            IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
              ICOP=IORIG
            ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
              GOTO 220
            ENDIF
          ENDIF
          IF(ICOP.NE.0) THEN
            NCOP=NCOP+1
            K(NCOP,3)=I
            DO 230 J=1,5
              P(NCOP,J)=P(I,J)
  230       CONTINUE
          ENDIF
  240   CONTINUE
 
C...Calculate relative rescaling factors.
        SLC=3-2*LESD
        PLCSUM=0D0
        DO 250 I=N+2,NCOP
          PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
  250   CONTINUE
        DO 260 I=N+2,NCOP
          V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
  260   CONTINUE
 
C...Transfer extra three-momentum of current.
        DO 280 I=N+2,NCOP
          DO 270 J=1,3
            P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
  270     CONTINUE
          P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
  280   CONTINUE
 
C...Iterate change of initiator momentum to get energy right.
        ITER=0
  290   ITER=ITER+1
        PEEX=-P(N+1,4)-QNEW(4)
        PEMV=-P(N+1,3)/P(N+1,4)
        DO 300 I=N+2,NCOP
          PEEX=PEEX+P(I,4)
          PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
  300   CONTINUE
        IF(ABS(PEMV).LT.1D-10) THEN
          MINT(51)=1
          MINT(57)=MINT(57)+1
          RETURN
        ENDIF
        PZCH=-PEEX/PEMV
        P(N+1,3)=P(N+1,3)+PZCH
        P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
        DO 310 I=N+2,NCOP
          P(I,3)=P(I,3)+V(I,1)*PZCH
          P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
  310   CONTINUE
        IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
 
C...Modify momenta in event record.
        HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
     &  ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
        IF(ABS(HBE).GE.1D0) THEN
          MINT(51)=1
          MINT(57)=MINT(57)+1
          RETURN
        ENDIF
        I=MINT(83)+5-LESD
        CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
        DO 330 I=N+1,NCOP
          ICOP=K(I,3)
          DO 320 J=1,4
            P(ICOP,J)=P(I,J)
  320     CONTINUE
  330   CONTINUE
      ENDIF
 
C...Check minimum invariant mass of remnant system(s).
      PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
      PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
      PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
      PMIN(0)=SQRT(PMS(0))
      DO 340 JT=1,2
        PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
        PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
        PMIN(JT)=0D0
        IF(MINT(44+JT).EQ.1) GOTO 340
        MINT(105)=MINT(102+JT)
        MINT(109)=MINT(106+JT)
        CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
        IF(MINT(51).NE.0) THEN
          MINT(57)=MINT(57)+1
          RETURN
        ENDIF           
        IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
        IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
        IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
        PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
     &  P(MINT(83)+JT+2,2)**2)
  340 CONTINUE
      IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
     &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
     &PSYS(2,4))) THEN
        MINT(51)=1
        MINT(57)=MINT(57)+1
        RETURN
      ENDIF
 
C...Loop over two remnants; skip if none there.
      I=NS
      DO 410 JT=1,2
        ISN(JT)=0
        IF(MINT(44+JT).EQ.1) GOTO 410
        IF(JT.EQ.1) IPU=IPU1
        IF(JT.EQ.2) IPU=IPU2
 
C...Store first remnant parton.
        I=I+1
        IS(JT)=I
        ISN(JT)=1
        DO 350 J=1,5
          K(I,J)=0
          P(I,J)=0D0
          V(I,J)=0D0
  350   CONTINUE
        K(I,1)=1
        K(I,2)=KFLSP(JT)
        K(I,3)=MINT(83)+JT
        P(I,5)=PYMASS(K(I,2))
 
C...First parton colour connections and kinematics.
        KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
        IF(KCOL.EQ.2) THEN
          K(I,1)=3
          K(I,4)=MSTU(5)*IPU+IPU
          K(I,5)=MSTU(5)*IPU+IPU
          K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
          K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
        ELSEIF(KCOL.NE.0) THEN
          K(I,1)=3
          KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
          K(I,KFLS+3)=IPU
          K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
        ENDIF
        IF(KFLCH(JT).EQ.0) THEN
          P(I,1)=-P(MINT(83)+JT+2,1)
          P(I,2)=-P(MINT(83)+JT+2,2)
          PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
          PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
          P(I,3)=PSYS(JT,3)
          P(I,4)=PSYS(JT,4)
 
C...When extra remnant parton or hadron: store extra remnant.
        ELSE
          I=I+1
          ISN(JT)=2
          DO 360 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  360     CONTINUE
          K(I,1)=1
          K(I,2)=KFLCH(JT)
          K(I,3)=MINT(83)+JT
          P(I,5)=PYMASS(K(I,2))
 
C...Find parton colour connections of extra remnant.
          KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
          IF(KCOL.EQ.2) THEN
            K(I,1)=3
            K(I,4)=MSTU(5)*IPU+IPU
            K(I,5)=MSTU(5)*IPU+IPU
            K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
            K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
          ELSEIF(KCOL.NE.0) THEN
            K(I,1)=3
            KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
            K(I,KFLS+3)=IPU
            K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
          ENDIF
 
C...Relative transverse momentum when two remnants.
          LOOP=0
  370     LOOP=LOOP+1
          CALL PYPTDI(1,P(I-1,1),P(I-1,2))
          IF(IABS(MINT(10+JT)).LT.20) THEN
            P(I-1,1)=0D0
            P(I-1,2)=0D0
          ELSE
            P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
            P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)        
          ENDIF
          PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
          P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
          P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
          PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
 
C...Meson or baryon; photon as meson. For splitup below.
          IMB=1
          IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
 
C***Relative distribution for electron into two electrons. Temporary!
          IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
     &    THEN
            CHI(JT)=PYR(0)
 
C...Relative distribution of electron energy into electron plus parton.
          ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
            XHRD=VINT(140+JT)
            XE=VINT(154+JT)
            CHI(JT)=(XE-XHRD)/(1D0-XHRD)
 
C...Relative distribution of energy for particle into two jets.
          ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
            CHIK=PARP(92+2*IMB)
            IF(MSTP(92).LE.1) THEN
              IF(IMB.EQ.1) CHI(JT)=PYR(0)
              IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
            ELSEIF(MSTP(92).EQ.2) THEN
              CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
            ELSEIF(MSTP(92).EQ.3) THEN
              CUT=2D0*0.3D0/VINT(1)
  380         CHI(JT)=PYR(0)**2
              IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
     &        (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
            ELSEIF(MSTP(92).EQ.4) THEN
              CUT=2D0*0.3D0/VINT(1)
              CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
  390         CHIR=CUT*CUTR**PYR(0)
              CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
              IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
            ELSE
              CUT=2D0*0.3D0/VINT(1)
              CUTA=CUT**(1D0-PARP(98))
              CUTB=(1D0+CUT)**(1D0-PARP(98))
  400         CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
              IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
     &        (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
            ENDIF
 
C...Relative distribution of energy for particle into jet plus particle.
          ELSE
            IF(MSTP(94).LE.1) THEN
              IF(IMB.EQ.1) CHI(JT)=PYR(0)
              IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
              IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
            ELSEIF(MSTP(94).EQ.2) THEN
              CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
              IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
            ELSEIF(MSTP(94).EQ.3) THEN
              CALL PYZDIS(1,0,PMS(JT+4),ZZ)
              CHI(JT)=ZZ
            ELSE
              CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
              CHI(JT)=ZZ
            ENDIF
          ENDIF
 
C...Construct total transverse mass; reject if too large.
          CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT))) 
          PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
          IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
            IF(LOOP.LT.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)
      IMPLICIT INTEGER(I-N)
      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. (Except elastic GVMD states.)
        IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
     &  MINT(106+JT).NE.3)) THEN
          N=N+1
          K(N,1)=1
          K(N,2)=KFH
          K(N,3)=I+2
          P(N,3)=PZ*(-1)**(JT+1)
          P(N,4)=PE
          P(N,5)=SQRT(VINT(62+JT))
 
C...Decay rho from elastic scattering of gamma with sin**2(theta)
C...distribution of decay products (in rho rest frame).
          IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
            NSAV=N
            DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
            P(N,3)=0D0
            P(N,4)=P(N,5)
            CALL PYDECY(NSAV)
            IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
              PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
              CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
              THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
              CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
  140         CTHE=2D0*PYR(0)-1D0
              IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
              CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
            ENDIF
            CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
          ENDIF
 
C...Diffracted particle: low-mass system to two particles.
        ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
          N=N+2
          K(N-1,1)=1
          K(N,1)=1
          K(N-1,3)=I+2
          K(N,3)=I+2
          PMMAS=SQRT(VINT(62+JT))
          NTRY=0
  150     NTRY=NTRY+1
          IF(NTRY.LT.20) THEN
            MINT(105)=MINT(102+JT)
            MINT(109)=MINT(106+JT)
            CALL PYSPLI(KFH,21,KFL1,KFL2)
            CALL PYKFDI(KFL1,0,KFL3,KF1)
            IF(KF1.EQ.0) GOTO 150
            CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
            IF(KF2.EQ.0) GOTO 150
          ELSE
            KF1=KFH
            KF2=111
          ENDIF
          PM1=PYMASS(KF1)
          PM2=PYMASS(KF2)
          IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
          K(N-1,2)=KF1
          K(N,2)=KF2
          P(N-1,5)=PM1
          P(N,5)=PM2
          PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
     &    4D0*PM1**2*PM2**2))/(2D0*PMMAS)
          P(N-1,3)=PZP
          P(N,3)=-PZP
          P(N-1,4)=SQRT(PM1**2+PZP**2)
          P(N,4)=SQRT(PM2**2+PZP**2)
          CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
     &    0D0,0D0,0D0)
          DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
          CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
 
C...Diffracted particle: valence quark kicked out.
        ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
     &    PARP(101))) THEN
          N=N+2
          K(N-1,1)=2
          K(N,1)=1
          K(N-1,3)=I+2
          K(N,3)=I+2
          MINT(105)=MINT(102+JT)
          MINT(109)=MINT(106+JT)
          CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
          P(N-1,5)=PYMASS(K(N-1,2))
          P(N,5)=PYMASS(K(N,2))
          SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
     &    4D0*P(N-1,5)**2*P(N,5)**2
          P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
     &    P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
          P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
          P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
          P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
 
C...Diffracted particle: gluon kicked out.
        ELSE
          N=N+3
          K(N-2,1)=2
          K(N-1,1)=2
          K(N,1)=1
          K(N-2,3)=I+2
          K(N-1,3)=I+2
          K(N,3)=I+2
          MINT(105)=MINT(102+JT)
          MINT(109)=MINT(106+JT)
          CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
          K(N-1,2)=21
          P(N-2,5)=PYMASS(K(N-2,2))
          P(N-1,5)=0D0
          P(N,5)=PYMASS(K(N,2))
C...Energy distribution for particle into two jets.
  160     IMB=1
          IF(MOD(KFH/1000,10).NE.0) IMB=2
          CHIK=PARP(92+2*IMB)
          IF(MSTP(92).LE.1) THEN
            IF(IMB.EQ.1) CHI=PYR(0)
            IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
          ELSEIF(MSTP(92).EQ.2) THEN
            CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
          ELSEIF(MSTP(92).EQ.3) THEN
            CUT=2D0*0.3D0/VINT(1)
  170       CHI=PYR(0)**2
            IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
     &      PYR(0)) GOTO 170
          ELSEIF(MSTP(92).EQ.4) THEN
            CUT=2D0*0.3D0/VINT(1)
            CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
  180       CHIR=CUT*CUTR**PYR(0)
            CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
            IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
          ELSE
            CUT=2D0*0.3D0/VINT(1)
            CUTA=CUT**(1D0-PARP(98))
            CUTB=(1D0+CUT)**(1D0-PARP(98))
  190       CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
            IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
     &      (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
          ENDIF
          IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
     &    VINT(62+JT)) GOTO 160
          SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
          PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
     &    (2D0*VINT(62+JT))
          PEI=SQRT(PZI**2+SQM)
          PQQP=(1D0-CHI)*(PEI+PZI)
          P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
          P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
          P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
          P(N-1,3)=P(N-1,4)*(-1)**JT
          P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
          P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
        ENDIF
 
C...Documentation lines.
        K(I+2,1)=21
        IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
        IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
     &  MINT(106+JT).EQ.3)) K(I+2,2)=10*(KFH/10)
        K(I+2,3)=I
        P(I+2,3)=PZ*(-1)**(JT+1)
        P(I+2,4)=PE
        P(I+2,5)=SQRT(VINT(62+JT))
  200 CONTINUE
 
C...Rotate outgoing partons/particles using cos(theta).
      IF(VINT(23).LT.0.9D0) THEN
        CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
      ELSE
        CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYDISG
C...Set up a DIS process as gamma* + f -> f, with beam remnant
C...and showering added consecutively. Photon flux by the PYGAGA
C...routine (if at all).
 
      SUBROUTINE PYDISG
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION PMS(4)

C...Choice of subprocess, number of documentation lines
      IDOC=7
      MINT(3)=IDOC-6
      MINT(4)=IDOC
      IPU1=MINT(84)+1
      IPU2=MINT(84)+2
      IPU3=MINT(84)+3
      ISIDE=1
      IF(MINT(107).EQ.4) ISIDE=2   
 
C...Reset K, P and V vectors. Store incoming particles
      DO 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
 
C...Store incoming partons in hadronic CM-frame
      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
  150 CONTINUE
      IF(MINT(15).EQ.22) THEN
        P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))     
        P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1)) 
        P(MINT(84)+1,5)=-SQRT(VINT(307))    
        P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)     
        P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1) 
        KFRES=MINT(16) 
        ISIDE=2   
      ELSE
        P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)     
        P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
        P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))     
        P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1)) 
        P(MINT(84)+1,5)=-SQRT(VINT(308))    
        KFRES=MINT(15)
        ISIDE=1    
      ENDIF
      SIDESG=(-1D0)**(ISIDE-1)     
 
C...Copy incoming partons to documentation lines.
      DO 170 JT=1,2
        I1=MINT(83)+4+JT
        I2=MINT(84)+JT
        K(I1,1)=21
        K(I1,2)=K(I2,2)
        K(I1,3)=I1-2
        DO 160 J=1,5
          P(I1,J)=P(I2,J)
  160   CONTINUE

C...Second copy for partons before ISR shower, since no such.
        I1=MINT(83)+2+JT
        K(I1,1)=21
        K(I1,2)=K(I2,2)
        K(I1,3)=I1-2
        DO 165 J=1,5
          P(I1,J)=P(I2,J)
  165   CONTINUE
  170 CONTINUE

C...Define initial partons.
      NTRY=0
  200 NTRY=NTRY+1
      IF(NTRY.GT.100) THEN
        MINT(51)=1
        RETURN
      ENDIF 

C...Scattered quark in hadronic CM frame.
      I=MINT(83)+7
      K(IPU3,1)=3
      K(IPU3,2)=KFRES
      K(IPU3,3)=I
      P(IPU3,5)=PYMASS(KFRES)
      P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
      P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
      P(IPU3,5)=0D0
      K(I,1)=21
      K(I,2)=KFRES
      K(I,3)=MINT(83)+4+ISIDE
      P(I,3)=P(IPU3,3)
      P(I,4)=P(IPU3,4)
      P(I,5)=P(IPU3,5)
      N=IPU3
      MINT(21)=KFRES
      MINT(22)=0

C...No primordial kT, or chosen according to truncated Gaussian or
C...exponential, or (for photon) predetermined or power law.
  220 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
        IF(MSTP(91).LE.0) THEN
          PT=0D0
        ELSEIF(MSTP(91).EQ.1) THEN
          PT=PARP(91)*SQRT(-LOG(PYR(0)))
        ELSE
          RPT1=PYR(0)
          RPT2=PYR(0)
          PT=-PARP(92)*LOG(RPT1*RPT2)
        ENDIF
        IF(PT.GT.PARP(93)) GOTO 220
      ELSEIF(MINT(106+ISIDE).EQ.3) THEN
        PTA=SQRT(VINT(282+ISIDE))
        PTB=0D0
        IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
          PTB=PARP(99)*SQRT(-LOG(PYR(0)))
        ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
          RPT1=PYR(0)
          RPT2=PYR(0)
          PTB=-PARP(99)*LOG(RPT1*RPT2)
        ENDIF
        IF(PTB.GT.PARP(100)) GOTO 220
        PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
        IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
      ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
        IF(MSTP(93).LE.0) THEN
          PT=0D0
        ELSEIF(MSTP(93).EQ.1) THEN
          PT=PARP(99)*SQRT(-LOG(PYR(0)))
        ELSEIF(MSTP(93).EQ.2) THEN
          RPT1=PYR(0)
          RPT2=PYR(0)
          PT=-PARP(99)*LOG(RPT1*RPT2)
        ELSEIF(MSTP(93).EQ.3) THEN
          HA=PARP(99)**2
          HB=PARP(100)**2
          PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
        ELSE
          HA=PARP(99)**2
          HB=PARP(100)**2
          IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
          PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
        ENDIF
        IF(PT.GT.PARP(100)) GOTO 220
      ELSE
        PT=0D0
      ENDIF
      VINT(156+ISIDE)=PT
      PHI=PARU(2)*PYR(0)
      P(IPU3,1)=PT*COS(PHI)
      P(IPU3,2)=PT*SIN(PHI)
      P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)  
      PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 
      PCP=P(IPU3,4)+ABS(P(IPU3,3))

C...Find one or two beam remnants.
      MINT(105)=MINT(102+ISIDE)
      MINT(109)=MINT(106+ISIDE)
      CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
      IF(MINT(51).NE.0) THEN
        MINT(51)=0
        GOTO 200
      ENDIF 

C...Store first remnant parton, with colour info and kinematics.
      I=N+1
      K(I,1)=1
      K(I,2)=KFLSP
      K(I,3)=MINT(83)+ISIDE
      P(I,5)=PYMASS(K(I,2))
      KCOL=KCHG(PYCOMP(KFLSP),2)
      IF(KCOL.NE.0) THEN
        K(I,1)=3
        KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
        K(I,KFLS+3)=MSTU(5)*IPU3
        K(IPU3,6-KFLS)=MSTU(5)*I
        ICOLR=I 
      ENDIF
      IF(KFLCH.EQ.0) THEN
        P(I,1)=-P(IPU3,1)
        P(I,2)=-P(IPU3,2)
        PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
        P(I,3)=-P(IPU3,3)
        P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
        PRP=P(I,4)+ABS(P(I,3))
 
C...When extra remnant parton or hadron: store extra remnant.
      ELSE
        I=I+1
        K(I,1)=1
        K(I,2)=KFLCH
        K(I,3)=MINT(83)+ISIDE
        P(I,5)=PYMASS(K(I,2))
        KCOL=KCHG(PYCOMP(KFLCH),2)
        IF(KCOL.NE.0) THEN
          K(I,1)=3
          KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
          K(I,KFLS+3)=MSTU(5)*IPU3
          K(IPU3,6-KFLS)=MSTU(5)*I
          ICOLR=I 
        ENDIF
 
C...Relative transverse momentum when two remnants.
        LOOP=0
  370   LOOP=LOOP+1
        CALL PYPTDI(1,P(I-1,1),P(I-1,2))
        P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
        P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)        
        PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
        P(I,1)=-P(IPU3,1)-P(I-1,1)
        P(I,2)=-P(IPU3,2)-P(I-1,2)
        PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
 
C...Relative distribution of energy for particle into jet plus particle.
        IMB=1
        IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
        IF(MSTP(94).LE.1) THEN
          IF(IMB.EQ.1) CHI=PYR(0)
          IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
          IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
        ELSEIF(MSTP(94).EQ.2) THEN
          CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
          IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
        ELSEIF(MSTP(94).EQ.3) THEN
          CALL PYZDIS(1,0,PMS(4),ZZ)
          CHI=ZZ
        ELSE
          CALL PYZDIS(1000,0,PMS(4),ZZ)
          CHI=ZZ
        ENDIF
 
C...Construct total transverse mass; reject if too large.
        CHI=MAX(1D-8,MIN(1D0-1D-8,CHI)) 
        PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
        IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
          IF(LOOP.LT.10) GOTO 370
          GOTO 200 
        ENDIF
        VINT(158+ISIDE)=CHI
 
C...Subdivide longitudinal momentum according to value selected above.
        PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
        PW1=(1D0-CHI)*PRP
        P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
        P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
        PW2=CHI*PRP
        P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
        P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
      ENDIF
      N=I

C...Boost current and remnant systems to correct frame.
      IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 200
      DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
      DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
     &(2D0*VINT(1)*PCP)
      DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
     &(2D0*VINT(1)*PRP)
      DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
      DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
      CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
      CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)

C...Let current quark shower; recoil but no showering by colour partner.
      QMAX=2D0*SQRT(VINT(309-ISIDE))
      MSTJ48=MSTJ(48)
      MSTJ(48)=1
      PARJ86=PARJ(86)
      PARJ(86)=0D0  
      IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
      MSTJ(48)=MSTJ48
      PARJ(86)=PARJ86            

      RETURN
      END
 
C*********************************************************************
 
C...PYDOCU
C...Handles the documentation of the process in MSTI and PARI,
C...and also computes cross-sections based on accumulated statistics.
 
      SUBROUTINE PYDOCU
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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-20.AND.XSECW.GT.1D-20) THEN
          FAC=XSECW/XSECH
          XSEC(11,3)=FAC*XSEC(11,3)
          XSEC(12,3)=FAC*XSEC(12,3)
          XSEC(13,3)=FAC*XSEC(13,3)
          XSEC(28,3)=FAC*XSEC(28,3)
          XSEC(53,3)=FAC*XSEC(53,3)
          XSEC(68,3)=FAC*XSEC(68,3)
          XSEC(95,3)=FAC*XSEC(95,3)
          XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
        ENDIF
      ENDIF
 
C...Save information for gamma-p and gamma-gamma.
      IF(MINT(121).GT.1) THEN
        IGA=MINT(122)
        CALL PYSAVE(2,IGA)
        CALL PYSAVE(5,0)
      ENDIF
 
C...Reset information on hard interaction.
      DO 110 J=1,200
        MSTI(J)=0
        PARI(J)=0D0
  110 CONTINUE
 
C...Copy integer valued information from MINT into MSTI.
      DO 120 J=1,32
        MSTI(J)=MINT(J)
  120 CONTINUE
      IF(MINT(121).GT.1) MSTI(9)=MINT(122)
 
C...Store cross-section variables in PARI.
      PARI(1)=XSEC(0,3)
      PARI(2)=XSEC(0,3)/MINT(5)
      PARI(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...Store information on lepton -> lepton + gamma in PYGAGA.
      MSTI(71)=MINT(141)
      MSTI(72)=MINT(142)
      PARI(101)=VINT(301)
      PARI(102)=VINT(302)
      DO 160 I=103,114
        PARI(I)=VINT(I+202)
  160 CONTINUE
 
C...Set information for PYTABU.
      IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
        MSTU(161)=MINT(21)
        MSTU(162)=0
      ELSEIF(ISET(ISUB).EQ.5) THEN
        MSTU(161)=MINT(23)
        MSTU(162)=0
      ELSE
        MSTU(161)=MINT(21)
        MSTU(162)=MINT(22)
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYFRAM
C...Performs transformations between different coordinate frames.
 
      SUBROUTINE PYFRAM(IFRAME)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYPARS/,/PYINT1/
 
C...Check that transformation can and should be done.
      IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
     &MINT(91).EQ.1)) THEN
        IF(IFRAME.EQ.MINT(6)) RETURN
      ELSE
        WRITE(MSTU(11),5000) IFRAME,MINT(6)
        RETURN
      ENDIF
 
      IF(MINT(6).EQ.1) THEN
C...Transform from fixed target or user specified frame to
C...overall CM frame.
        CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
        CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
        CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
      ELSEIF(MINT(6).EQ.3) THEN
C...Transform from hadronic CM frame in DIS to overall CM frame.
        CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
     &  -VINT(225))
      ENDIF
 
      IF(IFRAME.EQ.1) THEN
C...Transform from overall CM frame to fixed target or user specified
C...frame.
        CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
      ELSEIF(IFRAME.EQ.3) THEN
C...Transform from overall CM frame to hadronic CM frame in DIS.
        CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
        CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
        CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
      ENDIF
 
C...Set information about new frame.
      MINT(6)=IFRAME
      MSTI(6)=IFRAME
 
 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
     &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
     &1X,I5)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYWIDT
C...Calculates full and partial widths of resonances.
 
      SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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),WDTPP(0:200),WDTEP(0:200,0:5)
      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).
          WID2=1D0
          IF(MDME(IDC,1).GT.0) THEN
            IF(KFD2.EQ.KFD1) THEN
              IF(KCHG(KFC1,3).EQ.0) THEN
                WID2=WIDS(KFC1,1)
              ELSEIF(KFD1.GT.0) THEN
                WID2=WIDS(KFC1,4)
              ELSE
                WID2=WIDS(KFC1,5)
              ENDIF
              IF(KFD3.GT.0) THEN
                WID2=WID2*WIDS(KFC3,2)
              ELSEIF(KFD3.LT.0) THEN
                WID2=WID2*WIDS(KFC3,3)
              ENDIF
            ELSEIF(KFD2.EQ.-KFD1) THEN
              WID2=WIDS(KFC1,1)
              IF(KFD3.GT.0) THEN
                WID2=WID2*WIDS(KFC3,2)
              ELSEIF(KFD3.LT.0) THEN
                WID2=WID2*WIDS(KFC3,3)
              ENDIF
            ELSEIF(KFD3.EQ.KFD1) THEN
              IF(KCHG(KFC1,3).EQ.0) THEN
                WID2=WIDS(KFC1,1)
              ELSEIF(KFD1.GT.0) THEN
                WID2=WIDS(KFC1,4)
              ELSE
                WID2=WIDS(KFC1,5)
              ENDIF
              IF(KFD2.GT.0) THEN
                WID2=WID2*WIDS(KFC2,2)
              ELSEIF(KFD2.LT.0) THEN
                WID2=WID2*WIDS(KFC2,3)
              ENDIF
            ELSEIF(KFD3.EQ.-KFD1) THEN
              WID2=WIDS(KFC1,1)
              IF(KFD2.GT.0) THEN
                WID2=WID2*WIDS(KFC2,2)
              ELSEIF(KFD2.LT.0) THEN
                WID2=WID2*WIDS(KFC2,3)
              ENDIF
            ELSEIF(KFD3.EQ.KFD2) THEN
              IF(KCHG(KFC2,3).EQ.0) THEN
                WID2=WIDS(KFC2,1)
              ELSEIF(KFD2.GT.0) THEN
                WID2=WIDS(KFC2,4)
              ELSE
                WID2=WIDS(KFC2,5)
              ENDIF
              IF(KFD1.GT.0) THEN
                WID2=WID2*WIDS(KFC1,2)
              ELSEIF(KFD1.LT.0) THEN
                WID2=WID2*WIDS(KFC1,3)
              ENDIF
            ELSEIF(KFD3.EQ.-KFD2) THEN
              WID2=WIDS(KFC2,1)
              IF(KFD1.GT.0) THEN
                WID2=WID2*WIDS(KFC1,2)
              ELSEIF(KFD1.LT.0) THEN
                WID2=WID2*WIDS(KFC1,3)
              ENDIF
            ELSE
              IF(KFD1.GT.0) THEN
                WID2=WIDS(KFC1,2)
              ELSE
                WID2=WIDS(KFC1,3)
              ENDIF
              IF(KFD2.GT.0) THEN
                WID2=WID2*WIDS(KFC2,2)
              ELSE
                WID2=WID2*WIDS(KFC2,3)
              ENDIF
              IF(KFD3.GT.0) THEN
                WID2=WID2*WIDS(KFC3,2)
              ELSEIF(KFD3.LT.0) THEN
                WID2=WID2*WIDS(KFC3,3)
              ENDIF
            ENDIF
 
C...Store effective widths according to case.
            WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
            WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
            WDTE(I,0)=WDTE(I,MDME(IDC,1))
            WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
          ENDIF
  120   CONTINUE
C...Return.
        MINT(61)=0
        MINT(62)=0
        MINT(63)=0
        RETURN
      ENDIF
 
C...Here begins detailed dynamical calculation of resonance widths.
C...Shared treatment of Higgs states.
      KFHIGG=25
      IHIGG=1
      IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
        KFHIGG=KFLA
        IHIGG=KFLA-33
      ENDIF
 
C...Common electroweak and strong constants.
      XW=PARU(102)
      XWV=XW
      IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
      XW1=1D0-XW
      AEM=PYALEM(SH)
      IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
      AS=PYALPS(SH)
      RADC=1D0+AS/PARU(1)
 
      IF(KFLA.EQ.6) THEN
C...t quark.
        FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
        RADCT=1D0-2.5D0*AS/PARU(1)
        DO 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
          WID2=1D0
          IF(I.GE.4.AND.I.LE.7) THEN
C...t -> W + q; including approximate QCD correction factor.
            WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)
              IF(I.EQ.7) WID2=WID2*WIDS(7,2)
            ELSE
              WID2=WIDS(24,3)
              IF(I.EQ.7) WID2=WID2*WIDS(7,3)
            ENDIF
          ELSEIF(I.EQ.9) THEN
C...t -> H + b.
            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)/SH
              IF(KFLR.GT.0) THEN
                WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
              ELSE
                WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
              ENDIF
            ENDIF
          ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
C...t -> ~g + ~t
            KFC1=PYCOMP(KFDP(IDC,1))
            KFC2=PYCOMP(KFDP(IDC,2))
            PMNCHI=PMAS(KFC1,1)
            PMSTOP=PMAS(KFC2,1)
            IF(SHR.GT.PMNCHI+PMSTOP) THEN
              FL=SFMIX(6,1)
              FR=-SFMIX(6,2)
              PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
     &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
              WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((FL**2+FR**2)*
     &        (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*FL*FR)/SH
              IF(KFLR.GT.0) THEN
                WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
              ELSE
                WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
              ENDIF
            ENDIF
          ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
C...t -> ~gravitino + ~t
            XMP2=RMSS(29)**2
            KFC1=PYCOMP(KFDP(IDC,1))
            XMGR2=PMAS(KFC1,1)**2
            WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
            KFC2=PYCOMP(KFDP(IDC,2))
            WID2=WIDS(KFC2,2)
            IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
CMRENNA--
          ENDIF
          WDTP(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
          WID2=1D0
          IF(I.GE.4.AND.I.LE.7) THEN
C...b' -> W + q.
            WDTP(I)=FAC*VCKM(I-3,4)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,3)
              IF(I.EQ.6) WID2=WID2*WIDS(6,2)
              IF(I.EQ.7) WID2=WID2*WIDS(8,2)
            ELSE
              WID2=WIDS(24,2)
              IF(I.EQ.6) WID2=WID2*WIDS(6,3)
              IF(I.EQ.7) WID2=WID2*WIDS(8,3)
            ENDIF
            WID2=WIDS(24,3)
            IF(KFLR.LT.0) WID2=WIDS(24,2)
          ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
C...b' -> H + q.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(37,3)
              IF(I.EQ.10) WID2=WID2*WIDS(6,2)
            ELSE
              WID2=WIDS(37,2)
              IF(I.EQ.10) WID2=WID2*WIDS(6,3)
            ENDIF
          ENDIF
          WDTP(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
          WID2=1D0
          IF(I.GE.4.AND.I.LE.7) THEN
C...t' -> W + q.
            WDTP(I)=FAC*VCKM(4,I-3)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)
              IF(I.EQ.7) WID2=WID2*WIDS(7,2)
            ELSE
              WID2=WIDS(24,3)
              IF(I.EQ.7) WID2=WID2*WIDS(7,3)
            ENDIF
          ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
C...t' -> H + q.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(37,2)
              IF(I.EQ.10) WID2=WID2*WIDS(7,2)
            ELSE
              WID2=WIDS(37,3)
              IF(I.EQ.10) WID2=WID2*WIDS(7,3)
            ENDIF
          ENDIF
          WDTP(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
          WID2=1D0
          IF(I.EQ.3) THEN
C...tau' -> W + nu'_tau.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,3)
              WID2=WID2*WIDS(18,2)
            ELSE
              WID2=WIDS(24,2)
              WID2=WID2*WIDS(18,3)
            ENDIF
          ELSEIF(I.EQ.5) THEN
C...tau' -> H + nu'_tau.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(37,3)
              WID2=WID2*WIDS(18,2)
            ELSE
              WID2=WIDS(37,2)
              WID2=WID2*WIDS(18,3)
            ENDIF
          ENDIF
          WDTP(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
          WID2=1D0
          IF(I.EQ.2) THEN
C...nu'_tau -> W + tau'.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)
              WID2=WID2*WIDS(17,2)
            ELSE
              WID2=WIDS(24,3)
              WID2=WID2*WIDS(17,3)
            ENDIF
          ELSEIF(I.EQ.3) THEN
C...nu'_tau -> H + tau'.
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
            IF(KFLR.GT.0) THEN
              WID2=WIDS(37,2)
              WID2=WID2*WIDS(17,2)
            ELSE
              WID2=WIDS(37,3)
              WID2=WID2*WIDS(17,3)
            ENDIF
          ENDIF
          WDTP(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*(PYMRUN(KFDP(IDC,1),SH)**2/SH)*
     &      SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
C...A0 behaves like beta, ho and H0 like beta**3.
            IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
            IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
              IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
              IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
            ENDIF
            IF(I.EQ.6) WID2=WIDS(6,1)
            IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
 
          ELSEIF(I.LE.12) THEN
C...h0 -> l+ + l-
            WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))
C...A0 behaves like beta, ho and H0 like beta**3.
            IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
            IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
     &      PARU(153+10*IHIGG)**2
            IF(I.EQ.12) WID2=WIDS(17,1)
 
          ELSEIF(I.EQ.13) THEN
C...h0 -> g + g; quark loop contribution only
            ETARE=0D0
            ETAIM=0D0
            DO 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.1D-4) THEN
                  ROOT=SQRT(1D0-EPS)
                  RLN=LOG((1D0+ROOT)/(1D0-ROOT))
                ELSE
                  RLN=LOG(4D0/EPS-2D0)
                ENDIF
                PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
                PHIIM=0.5D0*PARU(1)*RLN
              ELSE
                PHIRE=(ASIN(1D0/SQRT(EPS)))**2
                PHIIM=0D0
              ENDIF
              IF(IHIGG.LE.2) THEN
                ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
                ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
              ELSE
                ETAREJ=-0.5D0*EPS*PHIRE
                ETAIMJ=-0.5D0*EPS*PHIIM
              ENDIF
C...Couplings (=1 for standard model Higgs).
              IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
                IF(MOD(J,2).EQ.1) THEN
                  ETAREJ=ETAREJ*PARU(151+10*IHIGG)
                  ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
                ELSE
                  ETAREJ=ETAREJ*PARU(152+10*IHIGG)
                  ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
                ENDIF
              ENDIF
              ETARE=ETARE+ETAREJ
              ETAIM=ETAIM+ETAIMJ
  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.1D-4) THEN
                  ROOT=SQRT(1D0-EPS)
                  RLN=LOG((1D0+ROOT)/(1D0-ROOT))
                ELSE
                  RLN=LOG(4D0/EPS-2D0)
                ENDIF
                PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
                PHIIM=0.5D0*PARU(1)*RLN
              ELSE
                PHIRE=(ASIN(1D0/SQRT(EPS)))**2
                PHIIM=0D0
              ENDIF
              IF(J.LE.3*MSTP(1)) THEN
C...Fermion loops: loop integral different for A0; charges.
                IF(IHIGG.LE.2) THEN
                  PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
                  PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
                ELSE
                  PHIPRE=-0.5D0*EPS*PHIRE
                  PHIPIM=-0.5D0*EPS*PHIIM
                ENDIF
                IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
                  EJC=3D0*EJ**2
                  EJH=PARU(151+10*IHIGG)
                ELSEIF(J.LE.2*MSTP(1)) THEN
                  EJC=3D0*EJ**2
                  EJH=PARU(152+10*IHIGG)
                ELSE
                  EJC=EJ**2
                  EJH=PARU(153+10*IHIGG)
                ENDIF
                IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
                ETAREJ=EJC*EJH*PHIPRE
                ETAIMJ=EJC*EJH*PHIPIM
              ELSEIF(J.EQ.3*MSTP(1)+1) THEN
C...W loops: loop integral and charges.
                ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
                ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
                IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
                  ETAREJ=ETAREJ*PARU(155+10*IHIGG)
                  ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
                ENDIF
              ELSE
C...Charged H loops: loop integral and charges.
                FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
     &          PARU(158+10*IHIGG+2*(IHIGG/3))
                ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
                ETAIMJ=-EPS**2*PHIIM*FACHHH
              ENDIF
              ETARE=ETARE+ETAREJ
              ETAIM=ETAIM+ETAIMJ
  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.1D-4) THEN
                  RLN=LOG((1D0+ROOT)/(1D0-ROOT))
                ELSE
                  RLN=LOG(4D0/EPS-2D0)
                ENDIF
                PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
                PHIIM=0.5D0*PARU(1)*RLN
                PSIRE=0.5D0*ROOT*RLN
                PSIIM=-0.5D0*ROOT*PARU(1)
              ELSE
                PHIRE=(ASIN(1D0/SQRT(EPS)))**2
                PHIIM=0D0
                PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
                PSIIM=0D0
              ENDIF
              IF(EPSP.LE.1D0) THEN
                ROOT=SQRT(1D0-EPSP)
                IF(EPSP.GT.1D-4) THEN
                  RLN=LOG((1D0+ROOT)/(1D0-ROOT))
                ELSE
                  RLN=LOG(4D0/EPSP-2D0)
                ENDIF
                PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
                PHIIMP=0.5D0*PARU(1)*RLN
                PSIREP=0.5D0*ROOT*RLN
                PSIIMP=-0.5D0*ROOT*PARU(1)
              ELSE
                PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
                PHIIMP=0D0
                PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
                PSIIMP=0D0
              ENDIF
              FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
     &        (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
              FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
     &        (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
              F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
              F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
              IF(J.LE.3*MSTP(1)) THEN
C...Fermion loops: loop integral different for A0; charges.
                IF(IHIGG.EQ.3) FXYRE=0D0
                IF(IHIGG.EQ.3) FXYIM=0D0
                IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
                  EJC=-3D0*EJ*VJ
                  EJH=PARU(151+10*IHIGG)
                ELSEIF(J.LE.2*MSTP(1)) THEN
                  EJC=-3D0*EJ*VJ
                  EJH=PARU(152+10*IHIGG)
                ELSE
                  EJC=-EJ*VJ
                  EJH=PARU(153+10*IHIGG)
                ENDIF
                IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
                ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
                ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
              ELSEIF(J.EQ.3*MSTP(1)+1) THEN
C...W loops: loop integral and charges.
                HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
                ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
                ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
                IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
                  ETAREJ=ETAREJ*PARU(155+10*IHIGG)
                  ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
                ENDIF
              ELSE
C...Charged H loops: loop integral and charges.
                FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
     &          PARU(158+10*IHIGG+2*(IHIGG/3))
                ETAREJ=FACHHH*FXYRE
                ETAIMJ=FACHHH*FXYIM
              ENDIF
              ETARE=ETARE+ETAREJ
              ETAIM=ETAIM+ETAIMJ
  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
          IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
            VPI=PARU(119+2*KFAIC)
            API=PARU(120+2*KFAIC)
          ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
            VPI=PARJ(178+2*KFAIC)
            API=PARJ(179+2*KFAIC)
          ELSE
            VPI=PARJ(186+2*KFAIC)
            API=PARJ(187+2*KFAIC)
          ENDIF
          SQMZ=PMAS(23,1)**2
          HZ=SHR*VINT(117)
          SQMZP=PMAS(32,1)**2
          HZP=SHR*WDTP(0)
          IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
     &    MSTP(44).EQ.7) VINT(111)=1D0
          IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
     &    2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
          IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
     &    2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
          IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
     &    MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
          IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
     &    2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
     &    (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
          IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
     &    MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
        ENDIF
        DO 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
              IF(I.LE.2) THEN
                VPF=PARU(123-2*MOD(I,2))
                APF=PARU(124-2*MOD(I,2))
              ELSEIF(I.LE.4) THEN
                VPF=PARJ(182-2*MOD(I,2))
                APF=PARJ(183-2*MOD(I,2))
              ELSE
                VPF=PARJ(190-2*MOD(I,2))
                APF=PARJ(191-2*MOD(I,2))
              ENDIF
              FCOF=3D0*RADC
              IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
     &        PYHFTH(SH,SH*RM1,1D0)
              IF(I.EQ.6) WID2=WIDS(6,1)
              IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
            ELSEIF(I.LE.16) THEN
C...Z'0 -> l+ + l-, nu + nubar
              EF=KCHG(I+2,1)/3D0
              AF=SIGN(1D0,EF+0.1D0)
              VF=AF-4D0*EF*XWV
              IF(I.LE.10) THEN
                VPF=PARU(127-2*MOD(I,2))
                APF=PARU(128-2*MOD(I,2))
              ELSEIF(I.LE.12) THEN
                VPF=PARJ(186-2*MOD(I,2))
                APF=PARJ(187-2*MOD(I,2))
              ELSE
                VPF=PARJ(194-2*MOD(I,2))
                APF=PARJ(195-2*MOD(I,2))
              ENDIF
              FCOF=1D0
              IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
            ENDIF
            BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
            IF(ICASE.EQ.1) THEN
              WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
              WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
     &        APF**2*(1D0-4D0*RM1))*BE34
            ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
              WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
     &        EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
     &        VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
     &        VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
     &        AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
     &        VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
            ELSEIF(MINT(61).EQ.2) THEN
              FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
              FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
              FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
              FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
              FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
     &        BE34
              FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
     &        BE34
            ENDIF
          ELSEIF(I.EQ.17) THEN
C...Z'0 -> W+ + W-
            WDTPZP=PARU(129)**2*XW1**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
            IF(ICASE.EQ.1) THEN
              WDTPZ=0D0
              WDTP(I)=FAC*WDTPZP
            ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
              WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
            ELSEIF(MINT(61).EQ.2) THEN
              FGGF=0D0
              FGZF=0D0
              FGZPF=0D0
              FZZF=0D0
              FZZPF=0D0
              FZPZPF=WDTPZP
            ENDIF
            WID2=WIDS(24,1)
          ELSEIF(I.EQ.18) THEN
C...Z'0 -> H+ + H-
            CZC=2D0*(1D0-2D0*XW)
            BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
            IF(ICASE.EQ.1) THEN
              WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
              WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
            ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
              WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
     &        VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
     &        (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
     &        (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
     &        (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
            ELSEIF(MINT(61).EQ.2) THEN
              FGGF=0.25D0*BE34C
              FGZF=0.25D0*PARU(142)*CZC*BE34C
              FGZPF=0.25D0*PARU(143)*CZC*BE34C
              FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
              FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
              FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
            ENDIF
            WID2=WIDS(37,1)
          ELSEIF(I.EQ.19) THEN
C...Z'0 -> Z0 + gamma.
          ELSEIF(I.EQ.20) THEN
C...Z'0 -> Z0 + h0
            FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
            WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
     &      (3D0*RM1+0.25D0*FLAM**2)*FLAM
            IF(ICASE.EQ.1) THEN
              WDTPZ=0D0
              WDTP(I)=FAC*WDTPZP
            ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
              WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
            ELSEIF(MINT(61).EQ.2) THEN
              FGGF=0D0
              FGZF=0D0
              FGZPF=0D0
              FZZF=0D0
              FZZPF=0D0
              FZPZPF=WDTPZP
            ENDIF
            WID2=WIDS(23,2)*WIDS(25,2)
          ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
C...Z' -> h0 + A0 or H0 + A0.
            BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            IF(I.EQ.21) THEN
              CZAH=PARU(186)
              CZPAH=PARU(188)
            ELSE
              CZAH=PARU(187)
              CZPAH=PARU(189)
            ENDIF
            IF(ICASE.EQ.1) THEN
              WDTPZ=CZAH**2*BE34C
              WDTP(I)=FAC*CZPAH**2*BE34C
            ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
              WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
     &        (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
     &        VINT(116))*BE34C
            ELSEIF(MINT(61).EQ.2) THEN
              FGGF=0D0
              FGZF=0D0
              FGZPF=0D0
              FZZF=CZAH**2*BE34C
              FZZPF=CZAH*CZPAH*BE34C
              FZPZPF=CZPAH**2*BE34C
            ENDIF
            IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
            IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
          ENDIF
          IF(ICASE.EQ.1) THEN
            VINT(117)=VINT(117)+FAC*WDTPZ
            WDTP(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=PYMRUN(KFDP(IDC,1),SH)**2/SH
            RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
            WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
     &      RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
            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
          ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
          IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
          IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
          ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
          IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
          IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
          WDTP(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.53) THEN
C...Techni-pi0 and techni-pi0':
        FAC=(1D0/(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 -> g + g
          IF(I.EQ.8) THEN
            FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2
     &      /(8D0*PARU(1))*SH*SHR
            IF(KFLA.EQ.51) THEN
              FACP=FACP*PARP(149)
            ELSE
              FACP=FACP*PARP(150)
            ENDIF
            WDTP(I)=FACP
          ELSE
C...pi_tech -> f + fbar.
            FCOF=1D0
            IKA=IABS(KFDP(IDC,1))
            IF(IKA.LT.10) FCOF=3D0*RADC
            HM1=PM1
            HM2=PM2
            IF(IKA.GE.4.AND.IKA.LE.6) THEN
               FCOF=FCOF*PARP(141+IKA)**2
               HM1=PYMRUN(KFDP(IDC,1),SH)
               HM2=PYMRUN(KFDP(IDC,2),SH)
            ELSEIF(IKA.EQ.15) THEN
               FCOF=FCOF*PARP(148)**2
            ENDIF
            WDTP(I)=FAC*FCOF*(HM1+HM2)**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
  340   CONTINUE
 
      ELSEIF(KFLA.EQ.52) THEN
C...pi+_tech
        FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR
        DO 350 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 350
          PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
          PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
          PM3=0D0
          IF(I.EQ.3) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
          RM1=PM1**2/SH
          RM2=PM2**2/SH
          RM3=PM3**2/SH
          IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
          WID2=1D0
C...pi_tech -> f + f'.
          FCOF=1D0
          IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
C...pi_tech+ -> W b b~
          IF(I.EQ.3.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
            FCOF=3D0*RADC
            XMT2=PMAS(6,1)**2/SH
            FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2
            KFC3=PYCOMP(KFDP(IDC,3))
            CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
            CHECK = SQRT(RM1)
            T0 = (1D0-CHECK**2)*
     &      (XMT2*(6.*XMT2**2+3.*XMT2*RM1-4.*RM1**2)-
     &      (5.*XMT2**2+2.*XMT2*RM1-8.*RM1**2))/(4.*XMT2**2)
            T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4.*RM1**2)
     &      -3.*XMT2**2*(XMT2+RM1))/(2.0*XMT2**3)
            T3 = RM1**2/XMT2**3*(3.0*XMT2-4.0*RM1+4.0*XMT2*RM1)
            WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
     &      +T3*LOG(CHECK))
            IF(KFLR.GT.0) THEN
               WID2=WIDS(24,2)
            ELSE
               WID2=WIDS(24,3)
            ENDIF
          ELSE
            FCOF=1D0
            IKA=IABS(KFDP(IDC,1))
            IF(IKA.LT.10) FCOF=3D0*RADC
            HM1=PM1
            HM2=PM2
            IF(I.GE.1.AND.I.LE.3) THEN
              FCOF=FCOF*PARP(144+I)**2
              HM1=PYMRUN(KFDP(IDC,1),SH)
              HM2=PYMRUN(KFDP(IDC,2),SH)
            ELSEIF(I.EQ.6) THEN
              FCOF=FCOF*PARP(148)**2
            ENDIF
            WDTP(I)=FAC*FCOF*(HM1+HM2)**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
  350     CONTINUE
 
      ELSEIF(KFLA.EQ.54) THEN
C...Techni-rho0:
        ALPRHT=2.91D0*(3D0/PARP(144))
        FAC=(ALPRHT/12D0)*SHR
        FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
        SQMZ=PMAS(23,1)**2
        SQMW=PMAS(24,1)**2
        SHP=SH
        CALL PYWIDX(23,SHP,WDTPP,WDTEP)
        GMMZ=SHR*WDTPP(0)
        XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
        BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
        BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
        DO 360 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 360
          RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
          RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
          IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
          WID2=1D0
          IF(I.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+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
     &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**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+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
     &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**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)
          ELSEIF(I.EQ.5) THEN
C...rho_tech0 -> gamma + pi_tech0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
     &      SHR**3
            WID2=WIDS(51,2)
          ELSEIF(I.EQ.6) THEN
C...rho_tech0 -> gamma + pi_tech0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*SHR**3
            WID2=WIDS(53,2)
          ELSEIF(I.EQ.7) THEN
C...rho_tech0 -> Z0 + pi_tech0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(51,2)
          ELSEIF(I.EQ.8) THEN
C...rho_tech0 -> Z0 + pi_tech0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARJ(174)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(53,2)
          ELSE
C...rho_tech0 -> f + fbar.
            WID2=1D0
            IF(I.LE.16) THEN
              IA=I-8
              FCOF=3D0*RADC
              IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
            ELSE
              IA=I-6
              FCOF=1D0
              IF(IA.GE.17) WID2=WIDS(IA,1)
            ENDIF
            EI=KCHG(IA,1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            VALI=0.5D0*(VI+AI)
            VARI=0.5D0*(VI-AI)
            WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
     &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
     &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
     &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
          ENDIF
          WDTP(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.55) THEN
C...Techni-rho+/-:
        ALPRHT=2.91D0*(3D0/PARP(144))
        FAC=(ALPRHT/12D0)*SHR
        SQMZ=PMAS(23,1)**2
        SQMW=PMAS(24,1)**2
        SHP=SH
        CALL PYWIDX(24,SHP,WDTPP,WDTEP)
        GMMW=SHR*WDTPP(0)
        FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
     &  (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
        DO 370 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 370
          RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
          RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
          IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
          WID2=1D0
          IF(I.EQ.1) THEN
C...rho_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+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
     &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(173)**2*SHR**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+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
     &      (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARJ(173)**2*SHR**3+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
     &      SHR**3*XW/XW1
            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
          ELSEIF(I.EQ.5) THEN
C...rho_tech+ -> pi_tech+ + gamma
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARJ(172)**2*
     &      SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(52,2)
            ELSE
              WID2=WIDS(52,3)
            ENDIF
          ELSEIF(I.EQ.6) THEN
C...rho_tech+ -> W+ + pi_tech0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARJ(174)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)*WIDS(53,2)
            ELSE
              WID2=WIDS(24,3)*WIDS(53,2)
            ENDIF
          ELSE
C...rho_tech+ -> f + fbar'.
            IA=I-6
            WID2=1D0
            IF(IA.LE.16) THEN
              FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
              IF(KFLR.GT.0) THEN
                IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
                IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
                IF(IA.GE.13) WID2=WID2*WIDS(7,3)
              ELSE
                IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
                IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
                IF(IA.GE.13) WID2=WID2*WIDS(7,2)
              ENDIF
            ELSE
              FCOF=1D0
              IF(KFLR.GT.0) THEN
                IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
              ELSE
                IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
              ENDIF
            ENDIF
            WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          ENDIF
          WDTP(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.56) THEN
C...Techni-omega:
        ALPRHT=2.91D0*(3D0/PARP(144))
        FAC=(ALPRHT/12D0)*SHR
        FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2
        SQMZ=PMAS(23,1)**2
        SHP=SH
        CALL PYWIDX(23,SHP,WDTPP,WDTEP)
        GMMZ=SHR*WDTPP(0)
        BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
        BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
        DO 380 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 380
          RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
          RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
          IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
          WID2=1D0
          IF(I.EQ.1) THEN
C...omega_tech0 -> gamma + pi_tech0.
            WDTP(I)=AEM/24D0/PARJ(172)**2*(1D0-PARP(141)**2)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
            WID2=WIDS(51,2)
          ELSEIF(I.EQ.2) THEN
C...omega_tech0 -> Z0 + pi_tech0 
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARP(141)**2)/24D0/PARJ(172)**2*(1D0-2D0*XW)**2/4D0/
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(51,2)
          ELSEIF(I.EQ.3) THEN
C...omega_tech0 -> gamma + pi_tech0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
     &      SHR**3
            WID2=WIDS(53,2)
          ELSEIF(I.EQ.4) THEN
C...omega_tech0 -> Z0 + pi_tech0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*PARP(143)-1D0)**2*(1D0-PARJ(174)**2)/24D0/PARJ(172)**2*
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(51,2)
          ELSEIF(I.EQ.5) THEN
C...omega_tech0 -> W+ + pi_tech-
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
     &      FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(24,2)*WIDS(52,3)
          ELSEIF(I.EQ.6) THEN
C...omega_tech0 -> pi_tech+ + W-
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-PARP(141)**2)/4D0/XW/24D0/PARJ(172)**2*SHR**3+
     &      FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARJ(175)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(24,3)*WIDS(52,2)
          ELSEIF(I.EQ.7) THEN
C...omega_tech0 -> W+ + W-.
            WDTP(I)=FAC*PARP(141)**4*PARJ(175)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(24,1)
          ELSEIF(I.EQ.8) THEN
C...omega_tech0 -> pi_tech+ + pi_tech-.
            WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARJ(175)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(52,1)
          ELSE
C...omega_tech0 -> f + fbar.
            WID2=1D0
            IF(I.LE.14) THEN
              IA=I-8
              FCOF=3D0*RADC
              IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
            ELSE
              IA=I-6
              FCOF=1D0
              IF(IA.GE.17) WID2=WIDS(IA,1)
            ENDIF
            EI=KCHG(IA,1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            VALI=0.5D0*(VI+AI)
            VARI=0.5D0*(VI-AI)
            WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
     &      ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
     &      (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
     &      (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
          ENDIF
          WDTP(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.61) THEN
C...H_L++/--:
        FAC=(1D0/(8D0*PARU(1)))*SHR
        DO 372 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 372
          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 372
          WID2=1D0
          IF(I.LE.6) THEN
C...H_L++/-- -> l+/- + l'+/-
            FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
     &      (IABS(KFDP(IDC,2))-9)/2)**2
C***Should be factor 4 below ???
            IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF 
          ELSEIF(I.EQ.7) THEN
C...H_L++/-- -> W_L+/- + W_L+/-
            FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
     &      (3D0*RM1+0.25D0/RM1-1D0)
            WID2=WIDS(24,4+(1-KFLS)/2)
          ENDIF
          WDTP(I)=FAC*FCOF*
     &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          WDTP(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
  372   CONTINUE

      ELSEIF(KFLA.EQ.62) THEN
C...H_R++/--:
        FAC=(1D0/(8D0*PARU(1)))*SHR
        DO 373 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 373
          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 373
          WID2=1D0
          IF(I.LE.6) THEN
C...H_R++/-- -> l+/- + l'+/-
            FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
     &      (IABS(KFDP(IDC,2))-9)/2)**2
            IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
          ELSEIF(I.EQ.7) THEN
C...H_R++/-- -> W_R+/- + W_R+/-
            FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
            WID2=WIDS(63,4+(1-KFLS)/2)
          ENDIF
          WDTP(I)=FAC*FCOF*
     &    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
 373   CONTINUE

      ELSEIF(KFLA.EQ.63) THEN
C...W_R+/-:
        FAC=(AEM/(24D0*XW))*SHR
        DO 374 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 374
          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 374
          WID2=1D0
          IF(I.LE.9) THEN
C...W_R+/- -> q + qbar'
            FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
            IF(KFLR.GT.0) THEN
              IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
            ELSE
              IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
            ENDIF
          ELSEIF(I.LE.12) THEN
C...W_R+/- -> l+/- + nu_R
            FCOF=1D0
          ENDIF
          WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
     &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          WDTP(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
 374   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+1) THEN
C...d* 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
          WID2=1D0
          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
  390   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+2) THEN
C...u* excited quark.
        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
          WID2=1D0
          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
  400   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+11) THEN
C...e* excited lepton.
        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
          WID2=1D0
          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
  410   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+12) THEN
C...nu*_e excited neutrino.
        FAC=(SH/PARU(155)**2)*SHR
        DO 420 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 420
          RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
          RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
          IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
          WID2=1D0
          IF(I.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
  420   CONTINUE
 
      ENDIF
      MINT(61)=0
      MINT(62)=0
      MINT(63)=0
 
      RETURN
      END
 
C***********************************************************************

C...PYWIDX
C...Calculates full and partial widths of resonances.
C....copy of PYWIDT, used for techniparticle widths
 
      SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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...Common electroweak and strong constants.
      XW=PARU(102)
      XWV=XW
      IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
      XW1=1D0-XW
      AEM=PYALEM(SH)
      IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
      AS=PYALPS(SH)
      RADC=1D0+AS/PARU(1)
  
      IF(KFLA.EQ.23) THEN
C...Z0:
        ICASE=1
        XWC=1D0/(16D0*XW*XW1)
        FAC=(AEM*XWC/3D0)*SHR
  200   CONTINUE
        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))
            WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
     &      BE34
            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
  210   CONTINUE

 
      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 
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYOFSH
C...Calculates partial width and differential cross-section maxima
C...of channels/processes not allowed on mass-shell, and selects
C...masses in such channels/processes.
 
      SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(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))
          IF(MBW(3-I).EQ.0) THEN
            PMU(I)=PMMX-PMD(3-I)
          ELSE
            PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
          ENDIF  
          IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
     &    MIN(PMU(I),CKIN(NOFF+2*ILM))
          IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
          IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
          IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
          IF(MBW(I).EQ.1) THEN
            ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
            ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
            IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
     &      PGD(I)))
          ENDIF
        ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
          ILM=I
          IF(MLM.EQ.2) ILM=3-I
          PML(I)=MAX(CKIN(48+I),PARP(42))
          PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
          IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
          IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
          IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
          IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
          IF(MBW(I).EQ.1) THEN
            ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
            ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
            IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
     &      PGD(I)))
          ENDIF
        ENDIF
  120 CONTINUE
      IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
     &THEN
        CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
        MINT(51)=1
        RETURN
      ENDIF
 
C...Calculation of partial width of resonance.
      IF(MOFSH.EQ.1) THEN
 
C..If only one integration, pick that to be the inner.
        IF(MBW(1).EQ.0) THEN
          PM2=PMD(1)
          PMD(1)=PMD(2)
          PGD(1)=PGD(2)
          PML(1)=PML(2)
          PMU(1)=PMU(2)
        ELSEIF(MBW(2).EQ.0) THEN
          PM2=PMD(2)
        ENDIF
 
C...Start outer loop of integration.
        IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
          ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
          ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
          NPT2=1
          XPT2(1)=1D0
          INX2(1)=0
          FMAX2=0D0
        ENDIF
  130   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
          PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
          PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
        ENDIF
        RM2=(PM2/PMMX)**2
 
C...Start inner loop of integration.
        PML1=PML(1)
        PMU1=MIN(PMU(1),PMMX-PM2)
        IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
        ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
        ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
        IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
          FUNC2=0D0
          GOTO 180
        ENDIF
        NPT1=1
        XPT1(1)=1D0
        INX1(1)=0
        FMAX1=0D0
  140   PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
        PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
        RM1=(PM1/PMMX)**2
 
C...Evaluate function value - inner loop.
        FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
        IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
        IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
     &  RM2**2+10D0*RM1*RM2)
        IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
        FPT1(NPT1)=FUNC1
 
C...Go to next position in inner loop.
        IF(NPT1.EQ.1) THEN
          NPT1=NPT1+1
          XPT1(NPT1)=0D0
          INX1(NPT1)=1
          GOTO 140
        ELSEIF(NPT1.LE.8) THEN
          NPT1=NPT1+1
          IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
          ISH1=ISH1+1
          XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
          INX1(NPT1)=INX1(ISH1)
          INX1(ISH1)=NPT1
          GOTO 140
        ELSEIF(NPT1.LT.100) THEN
          ISN1=ISH1
  150     ISH1=ISH1+1
          IF(ISH1.GT.NPT1) ISH1=2
          IF(ISH1.EQ.ISN1) GOTO 160
          DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
          IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
          NPT1=NPT1+1
          XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
          INX1(NPT1)=INX1(ISH1)
          INX1(ISH1)=NPT1
          GOTO 140
        ENDIF
 
C...Calculate integral over inner loop.
  160   FSUM1=0D0
        DO 170 IPT1=2,NPT1
          FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
     &    (XPT1(INX1(IPT1))-XPT1(IPT1))
  170   CONTINUE
        FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
  180   IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
          IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
          FPT2(NPT2)=FUNC2
 
C...Go to next position in outer loop.
          IF(NPT2.EQ.1) THEN
            NPT2=NPT2+1
            XPT2(NPT2)=0D0
            INX2(NPT2)=1
            GOTO 130
          ELSEIF(NPT2.LE.8) THEN
            NPT2=NPT2+1
            IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
            ISH2=ISH2+1
            XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
            INX2(NPT2)=INX2(ISH2)
            INX2(ISH2)=NPT2
            GOTO 130
          ELSEIF(NPT2.LT.100) THEN
            ISN2=ISH2
  190       ISH2=ISH2+1
            IF(ISH2.GT.NPT2) ISH2=2
            IF(ISH2.EQ.ISN2) GOTO 200
            DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
            IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
            NPT2=NPT2+1
            XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
            INX2(NPT2)=INX2(ISH2)
            INX2(ISH2)=NPT2
            GOTO 130
          ENDIF
 
C...Calculate integral over outer loop.
  200     FSUM2=0D0
          DO 210 IPT2=2,NPT2
            FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
     &      (XPT2(INX2(IPT2))-XPT2(IPT2))
  210     CONTINUE
          FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
          IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
        ELSE
          FSUM2=FUNC2
        ENDIF
 
C...Save result; second integration for user-selected mass range.
        IF(LOOP.EQ.1) WIDW=FSUM2
        WID2=FSUM2
        IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
     &  .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
          LOOP=2
          GOTO 100
        ENDIF
        RET1=WIDW
        RET2=WID2/WIDW
 
C...Select two decay product masses of a resonance.
      ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
  220   DO 230 I=1,2
          IF(MBW(I).EQ.0) GOTO 230
          PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
     &    (ATU(I)-ATL(I)))
          PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
          RMG(I)=(PMG(I)/PMMX)**2
  230   CONTINUE
        IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
     &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
 
C...Weight with matrix element (if none known, use beta factor).
        FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
        IF(MMED.EQ.1) THEN
          WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
        ELSEIF(MMED.EQ.2) THEN
          WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
     &    RMG(2)**2+10D0*RMG(1)*RMG(2))
        ELSEIF(MMED.EQ.3) THEN
          WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
        ELSE
          WTBE=FLAM
        ENDIF
        IF(WTBE.LT.PYR(0)) GOTO 220
        RET1=PMG(1)
        RET2=PMG(2)
 
C...Find suitable set of masses for initialization of 2 -> 2 processes.
      ELSEIF(MOFSH.EQ.3) THEN
        IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
          PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
          PMG(2)=PMD(2)
        ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
          PMG(1)=PMD(1)
          PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
        ELSE
          IDIV=-1
  240     IDIV=IDIV+1
          PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
          PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
          IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
        ENDIF
        RET1=PMG(1)
        RET2=PMG(2)
 
C...Evaluate importance of excluded tails of Breit-Wigners.
        IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
     &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
        IF(MEQL.LE.1) THEN
          VINT(80)=1D0
          DO 250 I=1,2
            IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
     &      PARU(1)
  250     CONTINUE
        ELSE
          VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
     &    (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
        ENDIF
        IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
     &  MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
        IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
        IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
 
C...Pick one particle to be the lighter (if improves efficiency).
      ELSEIF(MOFSH.EQ.4) THEN
        IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
     &  .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
  260   IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
 
C...Select two masses according to Breit-Wigner + flat in s + 1/s.
        DO 270 I=1,2
          IF(MBW(I).EQ.0) GOTO 270
          PMV=PMU(I)
          IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
          ATV=ATU(I)
          IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
          RBR=PYR(0)
          IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
     &    ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
          IF(RBR.LT.0.8D0) THEN
            PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
            PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
          ELSEIF(RBR.LT.0.9D0) THEN
            PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
          ELSEIF(RBR.LT.1.5D0) THEN
            PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
          ELSE
            PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
     &      (PMV**2-PML(I)**2))))
          ENDIF
  270   CONTINUE
        IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
     &  PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
          IF(MINT(48).EQ.1) THEN
            NGEN(0,1)=NGEN(0,1)+1
            NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
            GOTO 260
          ELSE
            MINT(51)=1
            RETURN
          ENDIF
        ENDIF
        RET1=PMG(1)
        RET2=PMG(2)
 
C...Give weight for selected mass distribution.
        VINT(80)=1D0
        DO 280 I=1,2
          IF(MBW(I).EQ.0) GOTO 280
          PMV=PMU(I)
          IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
          ATV=ATU(I)
          IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
          F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
     &    (PMD(I)*PGD(I))**2)/PARU(1)
          F1=1D0
          F2=1D0/PMG(I)**2
          F3=1D0/PMG(I)**4
          FI0=(ATV-ATL(I))/PARU(1)
          FI1=PMV**2-PML(I)**2
          FI2=2D0*LOG(PMV/PML(I))
          FI3=1D0/PML(I)**2-1D0/PMV**2
          IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
     &    ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
            VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
     &      5D0*F3/FI3))
          ELSE
            VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
          ENDIF
          VINT(80)=VINT(80)*FI0
  280   CONTINUE
        IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYRECO
C...Handles the possibility of colour reconnection in W+W- events,
C...Based on the main scenarios of the Sjostrand and Khoze study:
C...I, II, II', intermediate and instantaneous; plus one model
C...along the lines of the Gustafson and Hakkinen: GH.
C...Note: also handles Z0 Z0 and W-W+ events, but notation below
C...is as if first resonance is W+ and second W-.

      SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter value; number of points in MC integration.
      PARAMETER (NPT=100)
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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
      ISUB=MINT(1)
 
C...Common part for scenarios I, II, II', and GH.
      IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
     &MSTP(115).EQ.5) THEN
 
C...Read out frequently-used parameters.
        PI=PARU(1)
        HBAR=PARU(3)
        PMW=PMAS(24,1)
        IF(ISUB.EQ.22) PMW=PMAS(23,1)
        PGW=PMAS(24,2)
        IF(ISUB.EQ.22) PGW=PMAS(23,2)
        TFRAG=PARP(115)
        RHAD=PARP(116)
        FACT=PARP(117)
        BLOWR=PARP(118)
        BLOWT=PARP(119)
 
C...Find range of decay products of the W's.
C...Background: the W's are stored in IW1 and IW2.
C...Their direct decay products in NSD1+1 through NSD1+4.
C...Products after shower (if any) in NSD1+5 through NAFT1
C...for first W and in NAFT1+1 through N for the second.
        IF(NAFT1.GT.NSD1+4) THEN
          NBEG(1)=NSD1+5
          NEND(1)=NAFT1
        ELSE
          NBEG(1)=NSD1+1
          NEND(1)=NSD1+2
        ENDIF
        IF(N.GT.NAFT1) THEN
          NBEG(2)=NAFT1+1
          NEND(2)=N
        ELSE
          NBEG(2)=NSD1+3
          NEND(2)=NSD1+4
        ENDIF
 
C...Rearrange parton shower products along strings.
        NOLD=N
        CALL PYPREP(NSD1+1)
 
C...Find partons pointing back to W+ and W-; store them with quark
C...end of string first.
        NNP=0
        NNM=0
        ISGP=0
        ISGM=0
        DO 120 I=NOLD+1,N
          IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
          IF(IABS(K(I,2)).GE.22) GOTO 120
          IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
            IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
            NNP=NNP+1
            IF(ISGP.EQ.1) THEN
              INP(NNP)=I
            ELSE
              DO 100 I1=NNP,2,-1
                INP(I1)=INP(I1-1)
  100         CONTINUE
              INP(1)=I
            ENDIF
            IF(K(I,1).EQ.1) ISGP=0
          ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
            IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
            NNM=NNM+1
            IF(ISGM.EQ.1) THEN
              INM(NNM)=I
            ELSE
              DO 110 I1=NNM,2,-1
                INM(I1)=INM(I1-1)
  110         CONTINUE
              INM(1)=I
            ENDIF
            IF(K(I,1).EQ.1) ISGM=0
          ENDIF
  120   CONTINUE
 
C...Boost to W+W- rest frame (not strictly needed).
        DO 130 J=1,3
          BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
  130   CONTINUE
        CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
        CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
        CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
 
C...Select decay vertices of W+ and W-.
        TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
     &  SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
        TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
     &  SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
        GTMAX=MAX(TP,TM)
        DO 140 J=1,3
          XP(J)=TP*P(IW1,J)/P(IW1,4)
          XM(J)=TM*P(IW2,J)/P(IW2,4)
  140   CONTINUE
 
C...Begin scenario I specifics.
        IF(MSTP(115).EQ.1) THEN
 
C...Reconstruct velocity and direction of W+ string pieces.
          DO 170 IIP=1,NNP-1
            IF(K(INP(IIP),2).LT.0) GOTO 170
            I1=INP(IIP)
            I2=INP(IIP+1)
            P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
            P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
            DO 150 J=1,3
              V1(J)=P(I1,J)/P1A
              V2(J)=P(I2,J)/P2A
              BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
              DIRP(IIP,J)=V1(J)-V2(J)
  150       CONTINUE
            BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
     &      BETP(IIP,3)**2)
            DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
            DO 160 J=1,3
              DIRP(IIP,J)=DIRP(IIP,J)/DIRL
  160       CONTINUE
  170     CONTINUE
 
C...Reconstruct velocity and direction of W- string pieces.
          DO 200 IIM=1,NNM-1
            IF(K(INM(IIM),2).LT.0) GOTO 200
            I1=INM(IIM)
            I2=INM(IIM+1)
            P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
            P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
            DO 180 J=1,3
              V1(J)=P(I1,J)/P1A
              V2(J)=P(I2,J)/P2A
              BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
              DIRM(IIM,J)=V1(J)-V2(J)
  180       CONTINUE
            BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
     &      BETM(IIM,3)**2)
            DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
            DO 190 J=1,3
              DIRM(IIM,J)=DIRM(IIM,J)/DIRL
  190       CONTINUE
  200     CONTINUE
 
C...Loop over number of space-time points.
          NACC=0
          SUM=0D0
          DO 250 IPT=1,NPT
 
C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
            R=SQRT(-LOG(PYR(0)))
            PHI=2D0*PI*PYR(0)
            X=BLOWR*RHAD*R*COS(PHI)
            Y=BLOWR*RHAD*R*SIN(PHI)
            R=SQRT(-LOG(PYR(0)))
            PHI=2D0*PI*PYR(0)
            Z=BLOWR*RHAD*R*COS(PHI)
            T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
 
C...Reject impossible points. Weight for sample distribution.
            IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
            WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
     &      EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
 
C...Loop over W+ string pieces and find one with largest weight.
            IMAXP=0
            WTMAXP=1D-10
            XD(1)=X-XP(1)
            XD(2)=Y-XP(2)
            XD(3)=Z-XP(3)
            XD(4)=T-TP
            DO 220 IIP=1,NNP-1
              IF(K(INP(IIP),2).LT.0) GOTO 220
              BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
              BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
              DO 210 J=1,3
                XB(J)=XD(J)+BEDG*BETP(IIP,J)
  210         CONTINUE
              XB(4)=BETP(IIP,4)*(XD(4)-BED)
              SR2=XB(1)**2+XB(2)**2+XB(3)**2
              SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
     &        DIRP(IIP,3)*XB(3))**2
              WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
     &        TFRAG**2)
              IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
              IF(WTP.GT.WTMAXP) THEN
                IMAXP=IIP
                WTMAXP=WTP
              ENDIF
  220       CONTINUE
 
C...Loop over W- string pieces and find one with largest weight.
            IMAXM=0
            WTMAXM=1D-10
            XD(1)=X-XM(1)
            XD(2)=Y-XM(2)
            XD(3)=Z-XM(3)
            XD(4)=T-TM
            DO 240 IIM=1,NNM-1
              IF(K(INM(IIM),2).LT.0) GOTO 240
              BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
              BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
              DO 230 J=1,3
                XB(J)=XD(J)+BEDG*BETM(IIM,J)
  230         CONTINUE
              XB(4)=BETM(IIM,4)*(XD(4)-BED)
              SR2=XB(1)**2+XB(2)**2+XB(3)**2
              SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
     &        DIRM(IIM,3)*XB(3))**2
              WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
     &        TFRAG**2)
              IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
              IF(WTM.GT.WTMAXM) THEN
                IMAXM=IIM
                WTMAXM=WTM
              ENDIF
  240       CONTINUE
 
C...Result of integration.
            WT=0D0
            IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
              WT=WTMAXP*WTMAXM/WTSMP
              SUM=SUM+WT
              NACC=NACC+1
              IAP(NACC)=IMAXP
              IAM(NACC)=IMAXM
              WTA(NACC)=WT
            ENDIF
  250     CONTINUE
          RES=BLOWR**3*BLOWT*SUM/NPT
 
C...Decide whether to reconnect and, if so, where.
          IACC=0
          PREC=1D0-EXP(-FACT*RES)
          IF(PREC.GT.PYR(0)) THEN
            RSUM=PYR(0)*SUM
            DO 260 IA=1,NACC
              IACC=IA
              RSUM=RSUM-WTA(IA)
              IF(RSUM.LE.0D0) GOTO 270
  260       CONTINUE
  270       IIP=IAP(IACC)
            IIM=IAM(IACC)
          ENDIF
 
C...Begin scenario II and II' specifics.
        ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
 
C...Loop through all string pieces, one from W+ and one from W-.
          NCROSS=0
          TC(0)=0D0
          DO 340 IIP=1,NNP-1
            IF(K(INP(IIP),2).LT.0) GOTO 340
            I1P=INP(IIP)
            I2P=INP(IIP+1)
            DO 330 IIM=1,NNM-1
              IF(K(INM(IIM),2).LT.0) GOTO 330
              I1M=INM(IIM)
              I2M=INM(IIM+1)
 
C...Find endpoint velocity vectors.
              DO 280 J=1,3
                V1P(J)=P(I1P,J)/P(I1P,4)
                V2P(J)=P(I2P,J)/P(I2P,4)
                V1M(J)=P(I1M,J)/P(I1M,4)
                V2M(J)=P(I2M,J)/P(I2M,4)
  280         CONTINUE
 
C...Define q matrix and find t.
              DO 290 J=1,3
                Q(1,J)=V2P(J)-V1P(J)
                Q(2,J)=-(V2M(J)-V1M(J))
                Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
                Q(4,J)=V1P(J)-V1M(J)
  290         CONTINUE
              T=-DETER(1,2,3)/DETER(1,2,4)
 
C...Find alpha and beta; i.e. coordinates of crossing point.
              S11=Q(1,1)*(T-TP)
              S12=Q(2,1)*(T-TM)
              S13=Q(3,1)+Q(4,1)*T
              S21=Q(1,2)*(T-TP)
              S22=Q(2,2)*(T-TM)
              S23=Q(3,2)+Q(4,2)*T
              DEN=S11*S22-S12*S21
              ALP=(S12*S23-S22*S13)/DEN
              BET=(S21*S13-S11*S23)/DEN
 
C...Check if solution acceptable.
              IANSW=1
              IF(T.LT.GTMAX) IANSW=0
              IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
              IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
 
C...Find point of crossing and check that not inconsistent.
              DO 300 J=1,3
                XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
                XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
  300         CONTINUE
              D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
     &        (XPP(3)-XMM(3))**2
              D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
              D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
              IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
 
C...Find string eigentimes at crossing.
              IF(IANSW.EQ.1) THEN
                TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
     &          (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
                TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
     &          (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
              ELSE
                TAUP=0D0
                TAUM=0D0
              ENDIF
 
C...Order crossings by time. End loop over crossings.
              IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
                NCROSS=NCROSS+1
                DO 310 I1=NCROSS,1,-1
                  IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
                    IPC(I1)=IIP
                    IMC(I1)=IIM
                    TC(I1)=T
                    TPC(I1)=TAUP
                    TMC(I1)=TAUM
                    GOTO 320
                  ELSE
                    IPC(I1)=IPC(I1-1)
                    IMC(I1)=IMC(I1-1)
                    TC(I1)=TC(I1-1)
                    TPC(I1)=TPC(I1-1)
                    TMC(I1)=TMC(I1-1)
                  ENDIF
  310           CONTINUE
  320           CONTINUE
              ENDIF
  330       CONTINUE
  340     CONTINUE
 
C...Loop over crossings; find first (if any) acceptable one.
          IACC=0
          IF(NCROSS.GE.1) THEN
            DO 350 IC=1,NCROSS
              PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
              IF(PNFRAG.GT.PYR(0)) THEN
C...Scenario II: only compare with fragmentation time.
                IF(MSTP(115).EQ.2) THEN
                  IACC=IC
                  IIP=IPC(IACC)
                  IIM=IMC(IACC)
                  GOTO 360
C...Scenario II': also require that string length decreases.
                ELSE
                  IIP=IPC(IC)
                  IIM=IMC(IC)
                  I1P=INP(IIP)
                  I2P=INP(IIP+1)
                  I1M=INM(IIM)
                  I2M=INM(IIM+1)
                  ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
                  ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
                  IF(ELNEW.LT.ELOLD) THEN
                    IACC=IC
                    IIP=IPC(IACC)
                    IIM=IMC(IACC)
                    GOTO 360
                  ENDIF
                ENDIF
              ENDIF
  350       CONTINUE
  360       CONTINUE
          ENDIF
 
C...Begin scenario GH specifics.
        ELSEIF(MSTP(115).EQ.5) THEN
 
C...Loop through all string pieces, one from W+ and one from W-.
          IACC=0
          ELMIN=1D0
          DO 380 IIP=1,NNP-1
            IF(K(INP(IIP),2).LT.0) GOTO 380
            I1P=INP(IIP)
            I2P=INP(IIP+1)
            DO 370 IIM=1,NNM-1
              IF(K(INM(IIM),2).LT.0) GOTO 370
              I1M=INM(IIM)
              I2M=INM(IIM+1)
 
C...Look for largest decrease of (exponent of) Lambda measure.
              ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
              ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
              ELDIF=ELNEW/MAX(1D-10,ELOLD)
              IF(ELDIF.LT.ELMIN) THEN
                IACC=IIP+IIM
                ELMIN=ELDIF
                IPC(1)=IIP
                IMC(1)=IIM
              ENDIF
  370       CONTINUE
  380     CONTINUE
          IIP=IPC(1)
          IIM=IMC(1)
        ENDIF
 
C...Common for scenarios I, II, II' and GH: reconnect strings.
        IF(IACC.NE.0) THEN
          MINT(32)=1
          NJOIN=0
          DO 390 IS=1,NNP+NNM
            NJOIN=NJOIN+1
            IF(IS.LE.IIP) THEN
              I=INP(IS)
            ELSEIF(IS.LE.IIP+NNM-IIM) THEN
              I=INM(IS-IIP+IIM)
            ELSEIF(IS.LE.IIP+NNM) THEN
              I=INM(IS-IIP-NNM+IIM)
            ELSE
              I=INP(IS-NNM)
            ENDIF
            IJOIN(NJOIN)=I
            IF(K(I,2).LT.0) THEN
              CALL PYJOIN(NJOIN,IJOIN)
              NJOIN=0
            ENDIF
  390     CONTINUE
 
C...Restore original event record if no reconnection.
        ELSE
          DO 400 I=NSD1+1,NOLD
            IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
              K(I,4)=MOD(K(I,4),MSTU(5)**2)
              K(I,5)=MOD(K(I,5),MSTU(5)**2)
            ENDIF
  400     CONTINUE
          DO 410 I=NOLD+1,N
            K(K(I,3),1)=3
  410     CONTINUE
          N=NOLD
        ENDIF
 
C...Boost back system.
        CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
        CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
        IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
     &  BEWW(1),BEWW(2),BEWW(3))
 
C...Common part for intermediate and instantaneous scenarios.
      ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
        MINT(32)=1
 
C...Remove old shower products and reset showering ones.
        N=NSD1+4
        DO 420 I=NSD1+1,NSD1+4
          K(I,1)=3
          K(I,4)=MOD(K(I,4),MSTU(5)**2)
          K(I,5)=MOD(K(I,5),MSTU(5)**2)
  420   CONTINUE
 
C...Identify quark-antiquark pairs.
        IQ1=NSD1+1
        IQ2=NSD1+2
        IQ3=NSD1+3
        IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
        IQ4=2*NSD1+7-IQ3
 
C...Reconnect strings.
        IJOIN(1)=IQ1
        IJOIN(2)=IQ4
        CALL PYJOIN(2,IJOIN)
        IJOIN(1)=IQ3
        IJOIN(2)=IQ2
        CALL PYJOIN(2,IJOIN)
 
C...Do new parton showers in intermediate scenario.
        IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
          MSTJ50=MSTJ(50)
          MSTJ(50)=0
          CALL PYSHOW(IQ1,IQ2,P(IW1,5))
          CALL PYSHOW(IQ3,IQ4,P(IW2,5))
          MSTJ(50)=MSTJ50
 
C...Do new parton showers in instantaneous scenario.
        ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
          PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
     &    (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
          PPM=SQRT(MAX(0D0,PPM2))
          CALL PYSHOW(IQ1,IQ4,PPM)
          PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
     &    (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
          PPM=SQRT(MAX(0D0,PPM2))
          CALL PYSHOW(IQ3,IQ2,PPM)
        ENDIF
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYKLIM
C...Checks generated variables against pre-set kinematical limits;
C...also calculates limits on variables used in generation.
 
      SUBROUTINE PYKLIM(ILIM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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(MINT(45).EQ.2) THEN
          IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
        ENDIF
        IF(MINT(46).EQ.2) THEN
          IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
        ENDIF
        IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
          PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
          EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
     &    MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
          EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
     &    MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
          Y3=YST+0.5D0*LOG(EXPY3)
          Y4=YST+0.5D0*LOG(EXPY4)
          YLARGE=MAX(Y3,Y4)
          YSMALL=MIN(Y3,Y4)
          ETALAR=20D0
          ETASMA=-20D0
          STH=SQRT(MAX(0D0,1D0-CTH**2))
          EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
     &    CTH)**2-4D0*RM3))
          EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
     &    CTH)**2-4D0*RM4))
          IF(STH.GE.1D-10) THEN
            EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
     &      (BE34*STH)
            EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
     &      (BE34*STH)
            ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
            ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
            ETALAR=MAX(ETA3,ETA4)
            ETASMA=MIN(ETA3,ETA4)
          ENDIF
          CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
          CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
          CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
          CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
          SH=TAU*VINT(2)
          RPTS=4D0*VINT(71)**2/SH
          BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
          RM34=MAX(1D-20,2D0*RM3*RM4)
          IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
     &    RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
          RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
          THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
          UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
          IF(PTH.LT.PTHMIN) MINT(51)=1
          IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
          IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
          IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
          IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
          IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
          IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
          IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
          IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
          IF(THA.LT.CKIN(35)) MINT(51)=1
          IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
          IF(UHA.LT.CKIN(37)) MINT(51)=1
          IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
        ENDIF
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
          IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
          IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
        ENDIF
 
C...Additional cuts on W2 (approximately) in DIS.
        IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
          XBJ=X2
          IF(IABS(MINT(12)).LT.20) XBJ=X1
          Q2BJ=THA
          W2BJ=Q2BJ*(1D0-XBJ)/XBJ
          IF(W2BJ.LT.CKIN(39)) MINT(51)=1
          IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
        ENDIF
 
      ELSEIF(ILIM.EQ.1) THEN
C...Calculate limits on tau
C...0) due to definition
        TAUMN0=0D0
        TAUMX0=1D0
C...1) due to limits on subsystem mass
        TAUMN1=CKIN(1)**2/VINT(2)
        TAUMX1=1D0
        IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
        TM3=SQRT(SQM3+PTHMIN**2)
        TM4=SQRT(SQM4+PTHMIN**2)
        YDCOSH=1D0
        IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
        TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
        TAUMX2=1D0
C...3) due to limits on pT-hat and cos(theta-hat)
        CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
        CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
        TAUMN3=0D0
        IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
     &  (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
     &  SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
        TAUMX3=1D0
        IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
     &  (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
     &  SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
C...4) due to limits on x1 and x2
        TAUMN4=CKIN(21)*CKIN(23)
        TAUMX4=CKIN(22)*CKIN(24)
C...5) due to limits on xF
        TAUMN5=0D0
        TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
C...6) due to limits on that and uhat
        TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
        TAUMX6=1D0
        IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
     &  (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
 
C...Net effect of all separate limits.
        VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
        VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
        IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
          VINT(11)=1D0-1D-9
          VINT(31)=1D0+1D-9
        ELSEIF(MINT(47).EQ.5) THEN
          VINT(31)=MIN(VINT(31),1D0-2D-10)
        ELSEIF(MINT(47).GE.6) THEN
          VINT(31)=MIN(VINT(31),1D0-1D-10)
        ENDIF
        IF(VINT(31).LE.VINT(11)) MINT(51)=1
 
      ELSEIF(ILIM.EQ.2) THEN
C...Calculate limits on y*
        TAUE=TAU
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
        TAURT=SQRT(TAUE)
C...0) due to kinematics
        YSTMN0=LOG(TAURT)
        YSTMX0=-YSTMN0
C...1) due to explicit limits
        YSTMN1=CKIN(7)
        YSTMX1=CKIN(8)
C...2) due to limits on x1
        YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
        YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
C...3) due to limits on x2
        YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
        YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
C...4) due to limits on xF
        YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
        YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
        YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
        YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
C...5) due to simultaneous limits on y-large and y-small
        YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
        YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
        YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
        YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
        YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
        YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
C...6) due to simultaneous limits on cos(theta-hat) and y-large or
C...   y-small
        CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
        RZMN=BE34*MAX(CKIN(27),-CTHLIM)
        RZMX=BE34*MIN(CKIN(28),CTHLIM)
        YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
        YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
        YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
        YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
        YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
        YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
 
C...Net effect of all separate limits.
        VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
        VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
        IF(MINT(47).EQ.1) THEN
          VINT(12)=-1D-9
          VINT(32)=1D-9
        ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
          VINT(12)=(1D0-1D-9)*YSTMX0
          VINT(32)=(1D0+1D-9)*YSTMX0
        ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
          VINT(12)=-(1D0+1D-9)*YSTMX0
          VINT(32)=-(1D0-1D-9)*YSTMX0
        ELSEIF(MINT(47).EQ.5) THEN
          YSTEE=LOG((1D0-1D-10)/TAURT)
          VINT(12)=MAX(VINT(12),-YSTEE)
          VINT(32)=MIN(VINT(32),YSTEE)
        ENDIF
        IF(VINT(32).LE.VINT(12)) MINT(51)=1
 
      ELSEIF(ILIM.EQ.3) THEN
C...Calculate limits on cos(theta-hat)
        YST=VINT(22)
C...0) due to definition
        CTNMN0=-1D0
        CTNMX0=0D0
        CTPMN0=0D0
        CTPMX0=1D0
C...1) due to explicit limits
        CTNMN1=MIN(0D0,CKIN(27))
        CTNMX1=MIN(0D0,CKIN(28))
        CTPMN1=MAX(0D0,CKIN(27))
        CTPMX1=MAX(0D0,CKIN(28))
C...2) due to limits on pT-hat
        CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
        CTPMX2=-CTNMN2
        CTNMX2=0D0
        CTPMN2=0D0
        IF(CKIN(4).GE.0D0) THEN
          CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
     &    (BE34**2*TAU*VINT(2))))
          CTPMN2=-CTNMX2
        ENDIF
C...3) due to limits on y-large and y-small
        CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
     &  -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
        CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
     &  -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
        CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
     &  -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
        CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
     &  -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
C...4) due to limits on that
        CTNMN4=-1D0
        CTNMX4=0D0
        CTPMN4=0D0
        CTPMX4=1D0
        SH=TAU*VINT(2)
        IF(CKIN(35).GT.0D0) THEN
          CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
          IF(CTLIM.GT.0D0) THEN
            CTPMX4=CTLIM
          ELSE
            CTPMX4=0D0
            CTNMX4=CTLIM
          ENDIF
        ENDIF
        IF(CKIN(36).GT.0D0) THEN
          CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
          IF(CTLIM.LT.0D0) THEN
            CTNMN4=CTLIM
          ELSE
            CTNMN4=0D0
            CTPMN4=CTLIM
          ENDIF
        ENDIF
C...5) due to limits on uhat
        CTNMN5=-1D0
        CTNMX5=0D0
        CTPMN5=0D0
        CTPMX5=1D0
        IF(CKIN(37).GT.0D0) THEN
          CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
          IF(CTLIM.LT.0D0) THEN
            CTNMN5=CTLIM
          ELSE
            CTNMN5=0D0
            CTPMN5=CTLIM
          ENDIF
        ENDIF
        IF(CKIN(38).GT.0D0) THEN
          CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
          IF(CTLIM.GT.0D0) THEN
            CTPMX5=CTLIM
          ELSE
            CTPMX5=0D0
            CTNMX5=CTLIM
          ENDIF
        ENDIF
 
C...Net effect of all separate limits.
        VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
        VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
        VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
        VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
        IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
 
      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)=1D0-1D-9
          VINT(36)=1D0+1D-9
        ELSEIF(MINT(47).EQ.5) THEN
          VINT(36)=MIN(VINT(36),1D0-2D-10)
        ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
          VINT(36)=MIN(VINT(36),1D0-1D-10)
        ENDIF
        IF(VINT(36).LE.VINT(16)) MINT(51)=1
 
      ENDIF
      RETURN
 
C...Special case for low-pT and multiple interactions:
C...effective kinematical limits for tau, y*, cos(theta-hat).
  100 IF(ILIM.EQ.0) THEN
      ELSEIF(ILIM.EQ.1) THEN
        IF(MSTP(82).LE.1) THEN
          VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
     &    VINT(2)
        ELSE
          VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
        ENDIF
        VINT(31)=1D0
      ELSEIF(ILIM.EQ.2) THEN
        VINT(12)=0.5D0*LOG(VINT(21))
        VINT(32)=-VINT(12)
      ELSEIF(ILIM.EQ.3) THEN
        IF(MSTP(82).LE.1) THEN
          ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
     &    (VINT(21)*VINT(2))
        ELSE
          ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
     &    (VINT(21)*VINT(2))
        ENDIF
        VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
        VINT(33)=0D0
        VINT(14)=0D0
        VINT(34)=-VINT(13)
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYKMAP
C...Maps a uniform distribution into a distribution of a kinematical
C...variable according to one of the possibilities allowed. It is
C...assumed that kinematical limits have been set by a PYKLIM call.
 
      SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
 
C...Convert VVAR to tau variable.
      ISUB=MINT(1)
      ISTSB=ISET(ISUB)
      IF(IVAR.EQ.1) THEN
        TAUMIN=VINT(11)
        TAUMAX=VINT(31)
        IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
          TAURE=VINT(73)
          GAMRE=VINT(74)
        ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
          TAURE=VINT(75)
          GAMRE=VINT(76)
        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)
        ELSEIF(MINT(47).EQ.5) THEN
          AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
          ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
          TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
        ELSE
          AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
          ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
          TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
        ENDIF
        VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
 
C...Convert VVAR to y* variable.
      ELSEIF(IVAR.EQ.2) THEN
        YSTMIN=VINT(12)
        YSTMAX=VINT(32)
        TAUE=VINT(21)
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
        IF(MINT(47).EQ.1) THEN
          YST=0D0
        ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
          YST=-0.5D0*LOG(TAUE)
        ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
          YST=0.5D0*LOG(TAUE)
        ELSEIF(MVAR.EQ.1) THEN
          YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
        ELSEIF(MVAR.EQ.2) THEN
          YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
        ELSEIF(MVAR.EQ.3) THEN
          AUPP=ATAN(EXP(YSTMAX))
          ALOW=ATAN(EXP(YSTMIN))
          YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
        ELSEIF(MVAR.EQ.4) THEN
          YST0=-0.5D0*LOG(TAUE)
          AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
          ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
          YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
        ELSE
          YST0=-0.5D0*LOG(TAUE)
          AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
          ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
          YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
        ENDIF
        VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
 
C...Convert VVAR to cos(theta-hat) variable.
      ELSEIF(IVAR.EQ.3) THEN
        RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
        RSQM=1D0+RM34
        IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
     &  RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
        CTNMIN=VINT(13)
        CTNMAX=VINT(33)
        CTPMIN=VINT(14)
        CTPMAX=VINT(34)
        IF(MVAR.EQ.1) THEN
          ANEG=CTNMAX-CTNMIN
          APOS=CTPMAX-CTPMIN
          IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
            VCTN=VVAR*(ANEG+APOS)/ANEG
            CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
          ELSE
            VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
            CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
          ENDIF
        ELSEIF(MVAR.EQ.2) THEN
          RMNMIN=MAX(RM34,RSQM-CTNMIN)
          RMNMAX=MAX(RM34,RSQM-CTNMAX)
          RMPMIN=MAX(RM34,RSQM-CTPMIN)
          RMPMAX=MAX(RM34,RSQM-CTPMAX)
          ANEG=LOG(RMNMIN/RMNMAX)
          APOS=LOG(RMPMIN/RMPMAX)
          IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
            VCTN=VVAR*(ANEG+APOS)/ANEG
            CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
          ELSE
            VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
            CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
          ENDIF
        ELSEIF(MVAR.EQ.3) THEN
          RMNMIN=MAX(RM34,RSQM+CTNMIN)
          RMNMAX=MAX(RM34,RSQM+CTNMAX)
          RMPMIN=MAX(RM34,RSQM+CTPMIN)
          RMPMAX=MAX(RM34,RSQM+CTPMAX)
          ANEG=LOG(RMNMAX/RMNMIN)
          APOS=LOG(RMPMAX/RMPMIN)
          IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
            VCTN=VVAR*(ANEG+APOS)/ANEG
            CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
          ELSE
            VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
            CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
          ENDIF
        ELSEIF(MVAR.EQ.4) THEN
          RMNMIN=MAX(RM34,RSQM-CTNMIN)
          RMNMAX=MAX(RM34,RSQM-CTNMAX)
          RMPMIN=MAX(RM34,RSQM-CTPMIN)
          RMPMAX=MAX(RM34,RSQM-CTPMAX)
          ANEG=1D0/RMNMAX-1D0/RMNMIN
          APOS=1D0/RMPMAX-1D0/RMPMIN
          IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
            VCTN=VVAR*(ANEG+APOS)/ANEG
            CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
          ELSE
            VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
            CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
          ENDIF
        ELSEIF(MVAR.EQ.5) THEN
          RMNMIN=MAX(RM34,RSQM+CTNMIN)
          RMNMAX=MAX(RM34,RSQM+CTNMAX)
          RMPMIN=MAX(RM34,RSQM+CTPMIN)
          RMPMAX=MAX(RM34,RSQM+CTPMAX)
          ANEG=1D0/RMNMIN-1D0/RMNMAX
          APOS=1D0/RMPMIN-1D0/RMPMAX
          IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
            VCTN=VVAR*(ANEG+APOS)/ANEG
            CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
          ELSE
            VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
            CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
          ENDIF
        ENDIF
        IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
        IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
        VINT(23)=CTH
 
C...Convert VVAR to tau' variable.
      ELSEIF(IVAR.EQ.4) THEN
        TAU=VINT(21)
        TAUPMN=VINT(16)
        TAUPMX=VINT(36)
        IF(MINT(47).EQ.1) THEN
          TAUP=1D0
        ELSEIF(MVAR.EQ.1) THEN
          TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
        ELSEIF(MVAR.EQ.2) THEN
          AUPP=(1D0-TAU/TAUPMX)**4
          ALOW=(1D0-TAU/TAUPMN)**4
          TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
        ELSEIF(MINT(47).EQ.5) THEN
          AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
          ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
          TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
        ELSE
          AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
          ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
          TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
        ENDIF
        VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
 
C...Selection of extra variables needed in 2 -> 3 process:
C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
C...Since no options are available, the functions of PYKLIM
C...and PYKMAP are joint for these choices.
      ELSEIF(IVAR.EQ.5) THEN
 
C...Read out total energy and particle masses.
        MINT(51)=0
        MPTPK=1
        IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
     &  .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352) 
     &  MPTPK=2
        SHP=VINT(26)*VINT(2)
        SHPR=SQRT(SHP)
        PM1=VINT(201)
        PM2=VINT(206)
        PM3=SQRT(VINT(21))*VINT(1)
        IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
          MINT(51)=1
          RETURN
        ENDIF
        PMRS1=VINT(204)**2
        PMRS2=VINT(209)**2
 
C...Specify coefficients of pT choice; upper and lower limits.
        IF(MPTPK.EQ.1) THEN
          HWT1=0.4D0
          HWT2=0.4D0
        ELSE
          HWT1=0.05D0
          HWT2=0.05D0
        ENDIF
        HWT3=1D0-HWT1-HWT2
        PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
     &  (4D0*SHP)
        IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
        PTSMN1=CKIN(51)**2
        PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
     &  (4D0*SHP)
        IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
        PTSMN2=CKIN(53)**2
 
C...Select transverse momenta according to
C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
        HMX=PMRS1+PTSMX1
        HMN=PMRS1+PTSMN1
        IF(HMX.LT.1.0001D0*HMN) THEN
          MINT(51)=1
          RETURN
        ENDIF
        HDE=PTSMX1-PTSMN1
        RPT=PYR(0)
        IF(RPT.LT.HWT1) THEN
          PTS1=PTSMN1+PYR(0)*HDE
        ELSEIF(RPT.LT.HWT1+HWT2) THEN
          PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
        ELSE
          PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
        ENDIF
        WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
     &  HWT3*HMN*HMX/(PMRS1+PTS1)**2)
        HMX=PMRS2+PTSMX2
        HMN=PMRS2+PTSMN2
        IF(HMX.LT.1.0001D0*HMN) THEN
          MINT(51)=1
          RETURN
        ENDIF
        HDE=PTSMX2-PTSMN2
        RPT=PYR(0)
        IF(RPT.LT.HWT1) THEN
          PTS2=PTSMN2+PYR(0)*HDE
        ELSEIF(RPT.LT.HWT1+HWT2) THEN
          PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
        ELSE
          PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
        ENDIF
        WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
     &  HWT3*HMN*HMX/(PMRS2+PTS2)**2)
 
C...Select azimuthal angles and check pT choice.
        PHI1=PARU(2)*PYR(0)
        PHI2=PARU(2)*PYR(0)
        PHIR=PHI2-PHI1
        PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
        IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
     &  CKIN(56)**2)) THEN
          MINT(51)=1
          RETURN
        ENDIF
 
C...Calculate transverse masses and check phase space not closed.
        PMS1=PM1**2+PTS1
        PMS2=PM2**2+PTS2
        PMS3=PM3**2+PTS3
        PMT1=SQRT(PMS1)
        PMT2=SQRT(PMS2)
        PMT3=SQRT(PMS3)
        PM12=(PMT1+PMT2)**2
        IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
          MINT(51)=1
          RETURN
        ENDIF
 
C...Select rapidity for particle 3 and check phase space not closed.
        Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
     &  4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
        IF(Y3MAX.LT.1D-6) THEN
          MINT(51)=1
          RETURN
        ENDIF
        Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
        PZ3=PMT3*SINH(Y3)
        PE3=PMT3*COSH(Y3)
 
C...Find momentum transfers in two mirror solutions (in 1-2 frame).
        PZ12=-PZ3
        PE12=SHPR-PE3
        PMS12=PE12**2-PZ12**2
        SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
        IF(SQL12.LT.1D-6*SHP) THEN
          MINT(51)=1
          RETURN
        ENDIF
        PMM1=PMS12+PMS1-PMS2
        PMM2=PMS12+PMS2-PMS1
        TFAC=-SHPR/(2D0*PMS12)
        T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
        T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
        T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
        T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
 
C...Construct relative mirror weights and make choice.
        IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
          WTPU=1D0
          WTNU=1D0
        ELSE
          WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
          WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
        ENDIF
        WTP=WTPU/(WTPU+WTNU)
        WTN=WTNU/(WTPU+WTNU)
        EPS=1D0
        IF(WTN.GT.PYR(0)) EPS=-1D0
 
C...Store result of variable choice and associated weights.
        VINT(202)=PTS1
        VINT(207)=PTS2
        VINT(203)=PHI1
        VINT(208)=PHI2
        VINT(205)=WTPTS1
        VINT(210)=WTPTS2
        VINT(211)=Y3
        VINT(212)=Y3MAX
        VINT(213)=EPS
        IF(EPS.GT.0D0) THEN
          VINT(214)=1D0/WTP
          VINT(215)=T1P
          VINT(216)=T2P
        ELSE
          VINT(214)=1D0/WTN
          VINT(215)=T1N
          VINT(216)=T2N
        ENDIF
        VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
        VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
        VINT(219)=0.5D0*(PMS12-PTS3)
        VINT(220)=SQL12
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYSIGH
C...Differential matrix elements for all included subprocesses
C...Note that what is coded is (disregarding the COMFAC factor)
C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
C...when d(sigma-hat) is given in the zero-width limit, the delta
C...function in tau is replaced by a (modified) Breit-Wigner:
C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
C...where H_res = s-hat/m_res*Gamma_res(s-hat);
C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
C...i.e., dimensionless quantities
C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
C...(2pi)^4 delta^4(P - sum p_i)
C...COMFAC contains the factor pi/s (or equivalent) and
C...the conversion factor from GeV^-2 to mb
 
      SUBROUTINE PYSIGH(NCHN,SIGS)
 
C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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
      COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME,
     &DAA,DZZ,DAZ
 
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.301) 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=4D0
 
C...Stops
        ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
          ILR=0
          IF(ISUB.EQ.262) ILR=1
          ISUB=261
        ELSEIF(ISUB.EQ.265) THEN
          ISUB=264
 
C...Squarks
        ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
          ILR=0
          IF(ISUB.LE.273) THEN
            IF(ISUB.EQ.273) ILR=1
            ISUB=271
            RKF=16D0
          ELSEIF(ISUB.LE.276) THEN
            IF(ISUB.EQ.276) ILR=1
            ISUB=274
            RKF=16D0
          ELSEIF(ISUB.LE.278) THEN
            IF(ISUB.EQ.278) ILR=1
            ISUB=277
            RKF=4D0
          ELSE
            IF(ISUB.EQ.280) ILR=1
            ISUB=279
            RKF=4D0
          ENDIF
C...Sbottoms
        ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
          ILR=0
          IF(ISUB.LE.283) THEN
            IF(ISUB.EQ.283) ILR=1
            ISUB=271
            RKF=4D0
          ELSEIF(ISUB.LE.286) THEN
            IF(ISUB.EQ.286) ILR=1
            ISUB=274
            RKF=4D0
          ELSEIF(ISUB.LE.288) THEN
            IF(ISUB.EQ.288) ILR=1
            ISUB=277
            RKF=1D0
          ELSEIF(ISUB.LE.290) THEN
            IF(ISUB.EQ.290) ILR=1
            ISUB=279
            RKF=1D0
          ELSEIF(ISUB.LE.293) THEN
            IF(ISUB.EQ.293) ILR=1
            ISUB=271
            RKF=1D0
          ELSEIF(ISUB.EQ.296) THEN
            ILR=1
            ISUB=274
            RKF=1D0
C...Squark + gluino
          ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
            ISUB=258
            RKF=1D0
          ENDIF
C...H+/- + H0
        ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
          IF(ISUB.EQ.297) THEN
            RKF=.5D0*PARU(195)**2
          ELSEIF(ISUB.EQ.298) THEN
            RKF=.5D0*(1D0-PARU(195)**2)
          ENDIF
          ISUB=210
C...A0 + H0
        ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
          IF(ISUB.EQ.299) THEN
            RKF=PARU(186)**2
          ELSEIF(ISUB.EQ.300) THEN
            RKF=PARU(187)**2
          ENDIF
          ISUB=213
C...H+ + H-
        ELSEIF(ISUB.EQ.301) THEN
          KFID=37
          RKF=1D0
          ISUB=201
        ENDIF
      ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN
        SQTV=PARJ(172)**2
        SQTA=PARJ(173)**2
        TANW=SQRT(PARU(102)/(1D0-PARU(102)))
        CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
        CSXI=COS(ASIN(PARP(141)))
        CSXIP=COS(ASIN(PARJ(174)))
        QUPD=2D0*PARP(143)-1D0
C... rho_tech0 -> W_L W_L
        IF(ISUB.EQ.361) THEN
           KFA=24
           KFB=24
           CAB2=PARP(141)**4
C... rho_tech0 -> W_L pi_tech-
        ELSEIF(ISUB.EQ.362) THEN
           KFA=24
           KFB=52
           ISUB=361
           CAB2=PARP(141)**2*(1D0-PARP(141)**2)
C... pi_tech pi_tech
        ELSEIF(ISUB.EQ.363) THEN
           KFA=52
           KFB=52
           ISUB=361
           CAB2=(1D0-PARP(141)**2)**2
C... rho_tech0/omega_tech -> gamma pi_tech
        ELSEIF(ISUB.EQ.364) THEN
           KFA=22
           KFB=51
           VOGP=CSXI
           VRGP=VOGP*QUPD
           AOGP=0D0
           ARGP=0D0
C... gamma pi_tech'
        ELSEIF(ISUB.EQ.365) THEN
           KFA=22
           KFB=53
           ISUB=364
           VRGP=CSXIP
           VOGP=VRGP*QUPD
           AOGP=0D0
           ARGP=0D0
C... Z pi_tech
        ELSEIF(ISUB.EQ.366) THEN
           KFA=23
           KFB=51
           ISUB=364
           VOGP=CSXI*CT2W
           VRGP=-QUPD*CSXI*TANW
           AOGP=0D0
           ARGP=0D0
C... Z pi_tech'
        ELSEIF(ISUB.EQ.367) THEN
           KFA=23
           KFB=53
           ISUB=364
           VRGP=CSXIP*CT2W
           VOGP=-QUPD*CSXIP*TANW
           AOGP=0D0
           ARGP=0D0
C... W_T pi_tech
        ELSEIF(ISUB.EQ.368) THEN
           KFA=24
           KFB=52
           ISUB=364
           VOGP=CSXI/(2D0*SQRT(PARU(102)))
           VRGP=0D0
           AOGP=0D0
           ARGP=-VOGP
C... rho_tech+ -> W_L Z_L
        ELSEIF(ISUB.EQ.370) THEN
           KFA=24
           KFB=23
           CAB2=PARP(141)**4
C... W_L pi_tech0
        ELSEIF(ISUB.EQ.371) THEN
           KFA=24
           KFB=51
           ISUB=370
           CAB2=PARP(141)**2*(1D0-PARP(141)**2)
C... Z_L pi_tech+
        ELSEIF(ISUB.EQ.372) THEN
           KFA=52
           KFB=23
           ISUB=370
           CAB2=PARP(141)**2*(1D0-PARP(141)**2)
C... pi_tech+ pi_tech0
        ELSEIF(ISUB.EQ.373) THEN
           KFA=52
           KFB=51
           ISUB=370
           CAB2=(1D0-PARP(141)**2)**2
C... gamma pi_tech+
        ELSEIF(ISUB.EQ.374) THEN
           KFA=52
           KFB=22
           VRGP=QUPD*CSXI
           ARGP=0D0
C... Z_T pi_tech+
        ELSEIF(ISUB.EQ.375) THEN
           KFA=52
           KFB=23
           ISUB=374
           VRGP=-QUPD*CSXI*TANW
           ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
C... W_T pi_tech0
        ELSEIF(ISUB.EQ.376) THEN
           KFA=24
           KFB=51
           ISUB=374
           VRGP=0D0
           ARGP=-CSXI/(2D0*SQRT(PARU(102)))
C... W_T pi_tech0'
        ELSEIF(ISUB.EQ.377) THEN
           KFA=24
           KFB=53
           ISUB=374
           ARGP=0D0
           VRGP=CSXIP/(2D0*SQRT(PARU(102)))
        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.1D0-1D-7) RETURN
      ELSEIF(MINT(45).EQ.3) THEN
        X(1)=MIN(1D0-1.1D-10,X(1))
      ENDIF
      IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
        IF(X(2).GT.1D0-1D-7) RETURN
      ELSEIF(MINT(46).EQ.3) THEN
        X(2)=MIN(1D0-1.1D-10,X(2))
      ENDIF
      SH=MAX(1D0,TAU*VINT(2))
      SQM3=VINT(63)
      SQM4=VINT(64)
      RM3=SQM3/SH
      RM4=SQM4/SH
      BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
      RPTS=4D0*VINT(71)**2/SH
      BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
      RM34=MAX(1D-20,2D0*RM3*RM4)
      RSQM=1D0+RM34
      IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0) 
     &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
      RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
      IF(ISTSB.EQ.0) THEN
        TH=VINT(45)
        UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
        SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
      ELSE
C...Kinematics with incoming masses tricky: now depends on how
C...subprocess has been set up w.r.t. order of incoming partons. 
        RM1=0D0
        IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
        RM2=0D0
        IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
        IF(ISUB.EQ.35) THEN
          RM2=MIN(RM1,RM2)
          RM1=0D0
        ENDIF 
        BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
        TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
        TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
     &  BE12*BE34*CTH)
        UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
     &  BE12*BE34*CTH)
        SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
      ENDIF
      SHR=SQRT(SH)
      SH2=SH**2
      TH2=TH**2
      UH2=UH**2
 
C...Choice of Q2 scale: hard, parton distributions, parton showers
      IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
        Q2=SH
      ELSEIF(ISTSB.EQ.8) THEN
        IF(MINT(107).EQ.4) Q2=VINT(307) 
        IF(MINT(108).EQ.4) Q2=VINT(308) 
      ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
        Q2IN1=0D0
        IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
        Q2IN2=0D0
        IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2          
        IF(MSTP(32).EQ.1) THEN
          Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(MSTP(32).EQ.2) THEN
          Q2=SQPTH+0.5D0*(SQM3+SQM4)
        ELSEIF(MSTP(32).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ELSEIF(MSTP(32).EQ.4) THEN
          Q2=SH
        ELSEIF(MSTP(32).EQ.5) THEN
          Q2=-TH
        ELSEIF(MSTP(32).EQ.6) THEN
          XSF1=X(1)
          IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
          XSF2=X(2)
          IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
          Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
     &    (SQPTH+0.5D0*(SQM3+SQM4))
        ELSEIF(MSTP(32).EQ.7) THEN
          Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
        ELSEIF(MSTP(32).EQ.8) THEN
          Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
        ELSEIF(MSTP(32).EQ.9) THEN
          Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
        ELSEIF(MSTP(32).EQ.10) THEN
          Q2=VINT(2)
        ENDIF
        IF(ISTSB.EQ.9) Q2=SQPTH
        IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
     &  (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
      ENDIF
      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.OR.
     &  ISUB.EQ.351) Q2SF=PMAS(24,1)**2
        IF(ISUB.EQ.352) Q2SF=PMAS(63,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)
          IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2
        ENDIF
      ENDIF
      Q2PS=Q2SF
      Q2SF=Q2SF*PARP(34)
      IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
      IF(MSTP(69).GE.2) Q2SF=VINT(2)
      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).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.
     &ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144)) THEN 
        Q2PS=VINT(2)
      ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND.
     &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND.
     &ISUBSV.NE.68)) THEN
        Q2PS=VINT(2)
      ENDIF
 
C...Store derived kinematical quantities
      VINT(41)=X(1)
      VINT(42)=X(2)
      VINT(44)=SH
      VINT(43)=SQRT(SH)
      VINT(45)=TH
      VINT(46)=UH
      IF(ISTSB.NE.8) VINT(48)=SQPTH
      IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
      VINT(50)=TAUP*VINT(2)
      VINT(49)=SQRT(MAX(0D0,VINT(50)))
      VINT(52)=Q2
      VINT(51)=SQRT(Q2)
      VINT(54)=Q2SF
      VINT(53)=SQRT(Q2SF)
      VINT(56)=Q2PS
      VINT(55)=SQRT(Q2PS)
 
C...Calculate parton distributions
      IF(ISTSB.LE.0) GOTO 152
      IF(MINT(47).GE.2) THEN
        DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
          XSF=X(I)
          IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
          IF(ISUB.EQ.99) THEN
            XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
            Q2SF=VINT(309-I) 
          ENDIF
          MINT(105)=MINT(102+I)
          MINT(109)=MINT(106+I)
          VINT(120)=VINT(2+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)*(VINT(1)/PARP(89))**PARP(90)
        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)
      TANW=SQRT(XW/XW1)
      CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
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.8.AND.ISTSB.NE.9) THEN
        ATAU1=LOG(TAUMAX/TAUMIN)
        ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
        H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
        IF(MINT(72).GE.1) THEN
          TAUR1=VINT(73)
          GAMR1=VINT(74)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
          ATAU3=ATAUD/TAUR1
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
          ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
          ATAU4=ATAUD/GAMR1
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
        ENDIF
        IF(MINT(72).EQ.2) THEN
          TAUR2=VINT(75)
          GAMR2=VINT(76)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
          ATAU5=ATAUD/TAUR2
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
          ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
          ATAU6=ATAUD/GAMR2
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
        ENDIF
        IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
          ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
          IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
     &    MAX(2D-10,1D0-TAU)
        ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
          ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
          IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
     &    MAX(1D-10,1D0-TAU)
        ENDIF
        COMFAC=COMFAC*ATAU1/(TAU*H1)
      ENDIF
 
C...Phase space integral in y*
      IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9) 
     &THEN
        AYST0=YSTMAX-YSTMIN
        IF(AYST0.LT.1D-10) THEN
          COMFAC=0D0
        ELSE
          AYST1=0.5D0*(YSTMAX-YSTMIN)**2
          AYST2=AYST1
          AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
          H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
     &    (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
     &    (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
          IF(MINT(45).EQ.3) THEN
            YST0=-0.5D0*LOG(TAUE)
            AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
     &      MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
            IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
     &      MAX(1D-10,1D0-EXP(YST-YST0))
          ENDIF
          IF(MINT(46).EQ.3) THEN
            YST0=-0.5D0*LOG(TAUE)
            AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
     &      MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
            IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
     &      MAX(1D-10,1D0-EXP(-YST-YST0))
          ENDIF
          COMFAC=COMFAC*AYST0/H2
        ENDIF
      ENDIF
 
C...2 -> 1 processes: reduction in angular part of phase space integral
C...for case of decaying resonance
      ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
      IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
        IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
          IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
     &    KFPR(ISUB,1).EQ.39) THEN
            COMFAC=COMFAC*0.5D0*ACTH0
          ELSE
            COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
     &      CTPMAX**3-CTPMIN**3)
          ENDIF
        ENDIF
 
C...2 -> 2 processes: angular part of phase space integral
      ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
        ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
     &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
        ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
     &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
        ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
     &  1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
        ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
     &  1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
        H3=COEF(ISUBSV,13)+
     &  (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
     &  (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
     &  (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
     &  (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
        COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
 
C...2 -> 2 processes: take into account final state Breit-Wigners
        COMFAC=COMFAC*VINT(80)
      ENDIF
 
C...2 -> 3, 4 processes: phace space integral in tau'
      IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
        ATAUP1=LOG(TAUPMX/TAUPMN)
        ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
        H4=COEF(ISUBSV,18)+
     &  (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
        IF(MINT(47).EQ.5) THEN
          ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
          H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
        ELSEIF(MINT(47).GE.6) THEN
          ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
          H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
        ENDIF
        COMFAC=COMFAC*ATAUP1/H4
      ENDIF
 
C...2 -> 3, 4 processes: effective W/Z parton distributions
      IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
        IF(1D0-TAU/TAUP.GT.1D-4) THEN
          FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
        ELSE
          FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
        ENDIF
        COMFAC=COMFAC*FZW
      ENDIF
 
C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
      IF(ISTSB.EQ.5) THEN
        COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
     &  (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
      ENDIF
 
C...Phase space integral for low-pT and multiple interactions
      IF(ISTSB.EQ.9) THEN
        COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
        ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
        ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
        H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
        COMFAC=COMFAC*ATAU1/H1
        AYST0=YSTMAX-YSTMIN
        AYST1=0.5D0*(YSTMAX-YSTMIN)**2
        AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
        H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
     &  (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
     &  (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
        COMFAC=COMFAC*AYST0/H2
        IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
C...introduced to make cross-section finite for xT2 -> 0
        IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
     &  (1D0+VINT(149)))
      ENDIF
 
C...Real gamma + gamma: include factor 2 when different nature
  152 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
     &MSTP(14).LE.10) COMFAC=2D0*COMFAC

C...Extra factors to include the effects of 
C...longitudinal resolved photons (but not direct or DIS ones). 
      DO 155 ISDE=1,2
        IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
     &  MINT(106+ISDE).LE.3) THEN
          VINT(314+ISDE)=1D0
          XY=PARP(166+ISDE)
          IF(MSTP(16).EQ.0) THEN
            IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
     &      XY=VINT(304+ISDE)
          ELSE
            IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
     &      XY=VINT(308+ISDE)
          ENDIF
          Q2GA=VINT(306+ISDE)
          IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
     &    Q2GA.GT.0D0) THEN
            REDUCE=0D0
            IF(MSTP(17).EQ.1) THEN
              REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.2) THEN
              REDUCE=4D0*Q2GA/(Q2+Q2GA)
            ELSEIF(MSTP(17).EQ.3) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
              PMVSMN=4D0*PARP(15)**2
              PMVSMX=4D0*VINT(154)**2
              REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
              REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
     &        (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3  
              REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
              PMVSMN=4D0*PARP(15)**2
              PMVSMX=4D0*VINT(154)**2
              REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
              REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
              REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
            ENDIF
            BEAMAS=PYMASS(11) 
            IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
            FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
     &      (1D0-2D0*BEAMAS**2/Q2GA))
            VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
          ENDIF
        ELSE
          VINT(314+ISDE)=1D0
        ENDIF
        COMFAC=COMFAC*VINT(314+ISDE)
  155 CONTINUE
 
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.301.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
 
      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=PYMRUN(IA,SH)**2/SH
            HI=HP*RMQ
            IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
            IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
              IKFI=1
              IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
              IF(IA.GT.10) IKFI=3
              HI=HI*PARU(150+10*IHIGG+IKFI)**2
            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
          FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
          RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
          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)
            RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2)
          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
                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-1)=0.5D0*FACQQ1*RATQQI
                  SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
                ELSE
                  SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
                  SIGH(NCHN)=0.5D0*FACCI2*RATCII
                ENDIF
              ENDIF
  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)
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM4,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          HFGG=HFGG*HFAEM*VINT(111)/SQM4
          HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
          HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
          DO 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)
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM4,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          HFGG=HFGG*HFAEM*VINT(111)/SQM4
          HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
          HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
          DO 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)
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM3,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          DO 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
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM4,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          DO 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+/- (Z0 only, i.e. no gamma* admixture.)
          FACZW=COMFAC*0.5D0*(AEM/XW)**2
          FACZW=FACZW*WIDS(23,2)
          THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
          FACBW=1D0/((SH-SQMW)**2+GMMW**2)
          DO 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)
C***Protect against slightly negative cross sections. (Reason yet to be 
C***sorted out. One possibility: addition of width to the W propagator.)
              SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
  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
          GMMZC=GMMZ
          HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
          HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
          CALL PYWIDT(24,SQM3,WDTP,WDTE)
          GMMW3=SQRT(SQM3)*WDTP(0)
          HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
          HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
          CALL PYWIDT(24,SQM4,WDTP,WDTE)
          GMMW4=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
C...Kinematical functions
          THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
          THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
          GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
          GT=THUH34+4D0*THUH/TH2
          GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
          GU=THUH34+4D0*THUH/UH2
          GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
C...Common factors and couplings
          FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
          FACWW=FACWW*WIDS(24,1)
          CGG=AEM**2/2D0
          CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
          CZZ=AEM**2/(32D0*XW**2)*HBWZC
          CNG=AEM**2/(4D0*XW)
          CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
          CNN=AEM**2/(16D0*XW**2)
C...Coulomb factor for W+W- pair
          IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
            COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
            COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
            IF(COULE.LT.100D0*PMAS(24,2)) THEN
              COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
     &        PMAS(24,2)**2)-COULE))
            ELSE
              COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
            ENDIF
            IF(COULE.GT.-100D0*PMAS(24,2)) THEN
              COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
     &        PMAS(24,2)**2)+COULE))
            ELSE
              COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
     &        ABS(COULE)))
            ENDIF
            IF(MSTP(40).EQ.1) THEN
              COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
     &        MAX(1D-10,2D0*COULP*COULP1))
              FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
            ELSEIF(MSTP(40).EQ.2) THEN
              COULCK=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)
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM4,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          HFGG=HFGG*HFAEM*VINT(111)/SQM4
          HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
          HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
          DO 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)
          SQMHC=PMAS(25,1)**2
          FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
          DO 651 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.5) GOTO 651
            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=SQML
            FACHCQ=FHCQ*SQML/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 641 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 641
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 641
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
 641        CONTINUE
 651      CONTINUE
 
        ELSEIF(ISUB.EQ.33) THEN
C...f + gamma -> f + g (q + gamma -> q + g only)
          FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
          DO 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)
          IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
            FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
            FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2) 
          ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
            FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
            FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
          ELSE 
            FZQN=SH2+UH2+2D0*SQM4*TH
            FZQDTM=-SH*UH
          ENDIF       
          FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
C...gamma, gamma/Z interference and Z couplings to final fermion pairs
          HFGG=0D0
          HFGZ=0D0
          HFZZ=0D0
          RADC4=1D0+PYALPS(SQM4)/PARU(1)
          DO 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)
          MINT15=MINT(15)
          MINT(15)=1
          MINT(61)=1
          CALL PYWIDT(23,SQM4,WDTP,WDTE)
          MINT(15)=MINT15 
          HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
          HFGG=HFGG*HFAEM*VINT(111)/SQM4
          HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
          HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
C...Loop over flavours; consider full gamma/Z structure
          DO 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
            FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)  
            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/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
          SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQMA)**2+
     &    (UH-SQMA)**2)/SH2+2D0*SQMA/SH)
          IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMA,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
          SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          IF(MSTP(34).EQ.0) THEN
            FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
     &      2D0*(UH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
     &      (TH-SQMA)**2)
            FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
     &      2D0*(TH-SQMA)**2/SH2+4D0*(SQMA/SH)*(TH*UH-SQMA**2)/
     &      (UH-SQMA)**2)
          ELSE
            FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQMA)/(TH-SQMA)-
     &      2.25D0*(UH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
     &      (TH-SQMA)**2+0.5D0*SQMA*TH/(TH-SQMA)**2-SQMA**2/
     &      (SH*(TH-SQMA)))
            FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQMA)/(UH-SQMA)-
     &      2.25D0*(TH-SQMA)**2/SH2+4.5D0*(SQMA/SH)*(TH*UH-SQMA**2)/
     &      (UH-SQMA)**2+0.5D0*SQMA*UH/(UH-SQMA)**2-SQMA**2/
     &      (SH*(UH-SQMA)))
          ENDIF
          IF(MSTP(35).GE.1) THEN
            FATRE=PYHFTH(SH,SQMA,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
          SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
          FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
     &    ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-TH)+4D0*FMTU*(1D0-FMTU))
          IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMA,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)
          SQMA=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          FMTU=SQMA/(SQMA-TH)+SQMA/(SQMA-UH)
          FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
     &    ((SQMA-TH)/(SQMA-UH)+(SQMA-UH)/(SQMA-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,SQMA,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=VINT(315)*VINT(316)*SIGT(0,0,1)
 
        ELSEIF(ISUB.EQ.92) THEN
C...Single diffractive scattering (first side, i.e. XB)
          SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
 
        ELSEIF(ISUB.EQ.93) THEN
C...Single diffractive scattering (second side, i.e. AX)
          SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
 
        ELSEIF(ISUB.EQ.94) THEN
C...Double diffractive scattering
          SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
 
        ELSEIF(ISUB.EQ.95) THEN
C...Low-pT scattering
          SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
 
        ELSEIF(ISUB.EQ.96) THEN
C...Multiple interactions: sum of QCD processes
          CALL PYWIDT(21,SH,WDTP,WDTE)
 
C...q + q' -> q + q'
          FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
          FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
     &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
          FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
          FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
          RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
          DO 1040 I=-5,5
            IF(I.EQ.0) GOTO 1040
            DO 1030 J=-5,5
              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*FACQQ1*RATQQI
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=112
                SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
              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=-5,5
            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=-5,5
            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
 
        ELSEIF(ISUB.EQ.99) THEN
C...f + gamma* -> f.
          IF(MINT(107).EQ.4) THEN
            Q2GA=VINT(307)
            P2GA=VINT(308)
            ISDE=2
          ELSE
            Q2GA=VINT(308)
            P2GA=VINT(307)
            ISDE=1
          ENDIF
          COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
          PM2RHO=PMAS(PYCOMP(113),1)**2
          IF(MSTP(19).EQ.0) THEN
            COMFAC=COMFAC/Q2GA
          ELSEIF(MSTP(19).EQ.1) THEN  
            COMFAC=COMFAC/(Q2GA+PM2RHO)
          ELSEIF(MSTP(19).EQ.2) THEN  
            COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
          ELSE 
            COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
            W2GA=VINT(2)
            IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
              RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
     &        Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
              XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
            ELSE
              RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
     &        Q2GA**0.57D0)
              XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
            ENDIF
            COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
            IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
          ENDIF
          DO 1075 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1075
            IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1075
            EI=KCHG(IABS(I),1)/3D0
            NCHN=NCHN+1
            ISIG(NCHN,ISDE)=I
            ISIG(NCHN,3-ISDE)=22
            ISIG(NCHN,3)=1
            SIGH(NCHN)=COMFAC*EI**2
 1075     CONTINUE
        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
 
      ELSEIF(ISUB.EQ.104) THEN
C...g + g -> chi_c0.
        KC=PYCOMP(10441)
        FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
     &  ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
        IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
        IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACBW
        ENDIF
 
      ELSEIF(ISUB.EQ.105) THEN
C...g + g -> chi_c2.
        KC=PYCOMP(445)
        FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
     &  ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
        IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
        IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACBW
        ENDIF
 
C...Continuation C: 2 -> 2, tree diagrams with masses.
 
      ELSEIF(ISUB.EQ.106) THEN
C...g + g -> J/Psi + gamma.
        EQ=2D0/3D0
        FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
     &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
     &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
        IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACQQG
        ENDIF
 
      ELSEIF(ISUB.EQ.107) THEN
C...g + gamma -> J/Psi + g.
        EQ=2D0/3D0
        FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
     &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
     &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
        IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=22
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACQQG
        ENDIF
        IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=22
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACQQG
        ENDIF
 
      ELSEIF(ISUB.EQ.108) THEN
C...gamma + gamma -> J/Psi + gamma.
        EQ=2D0/3D0
        FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
     &  (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
     &  ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
        IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
          NCHN=NCHN+1
          ISIG(NCHN,1)=22
          ISIG(NCHN,2)=22
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACQQG
        ENDIF
 
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.1D-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.1D-4) THEN
              B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
     &        PARU(1)**2)
              B0STUI=0D0
              B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
              B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
              B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
              B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
              B1STUR=-1D0
              B1STUI=0D0
              B2STUR=-1D0
              B2STUI=0D0
            ELSE
              CALL PYWAUX(1,EPSS,W1SR,W1SI)
              CALL PYWAUX(1,EPST,W1TR,W1TI)
              CALL PYWAUX(1,EPSU,W1UR,W1UI)
              CALL PYWAUX(2,EPSS,W2SR,W2SI)
              CALL PYWAUX(2,EPST,W2TR,W2TI)
              CALL PYWAUX(2,EPSU,W2UR,W2UI)
              CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
              CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
              CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
              CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
              CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
              CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
              B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
     &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
     &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
     &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
     &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
     &        0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
              B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
     &        0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
     &        0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
     &        0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
     &        0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
     &        0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
              B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
     &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
     &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
     &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
     &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
     &        0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
              B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
     &        0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
     &        0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
     &        0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
     &        0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
     &        0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
              B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
     &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
     &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
     &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
     &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
     &        0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
              B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
     &        0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
     &        0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
     &        0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
     &        0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
     &        0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
              B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
     &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
     &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
     &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
              B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
     &        0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
     &        0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
     &        0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
              B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
     &        0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
     &        0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
              B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
     &        0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
     &        0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
            ENDIF
            A0STUR=A0STUR+EIWT*B0STUR
            A0STUI=A0STUI+EIWT*B0STUI
            A0TSUR=A0TSUR+EIWT*B0TSUR
            A0TSUI=A0TSUI+EIWT*B0TSUI
            A0UTSR=A0UTSR+EIWT*B0UTSR
            A0UTSI=A0UTSI+EIWT*B0UTSI
            A1STUR=A1STUR+EIWT*B1STUR
            A1STUI=A1STUI+EIWT*B1STUI
            A2STUR=A2STUR+EIWT*B2STUR
            A2STUI=A2STUI+EIWT*B2STUI
 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=PYMRUN(IA,SH)
          FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
     &    (0.5D0*PMF/PMAS(24,1))**2
          WID2=1D0
          IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
          FACQQH=FACQQH*WID2
          IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
            IKFI=1
            IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
            IF(IA.GT.10) IKFI=3
            FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
          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=PYMRUN(IA,SH)
          FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
     &    (0.5D0*PMF/PMAS(24,1))**2
          WID2=1D0
          IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
          FACQQH=FACQQH*WID2
          IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
            IKFI=1
            IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
            IF(IA.GT.10) IKFI=3
            FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
          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.OR.ISUB.EQ.132) THEN
C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
          PH=0D0
          IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) 
     &    PH=VINT(3)**2
          IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) 
     &    PH=VINT(4)**2
          IF(ISUB.EQ.131) THEN
            FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
     &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
          ELSE
            FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
          ENDIF
          DO 1280 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1280
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**2
            DO 1270 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1270
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1270
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
 1270       CONTINUE
 1280     CONTINUE
 
        ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
C...f + gamma*_(T,L) -> f + gamma
          PH=0D0
          IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) 
     &    PH=VINT(3)**2
          IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) 
     &    PH=VINT(4)**2
          IF(ISUB.EQ.133) THEN
            FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
     &      ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
          ELSE
            FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
          ENDIF
          DO 1300 I=MMINA,MMAXA
            IF(I.EQ.0) GOTO 1300
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**4
            DO 1290 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1290
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1290
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
 1290       CONTINUE
 1300     CONTINUE
 
        ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
          PH=0D0
          IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) 
     &    PH=VINT(3)**2
          IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) 
     &    PH=VINT(4)**2
          CALL PYWIDT(21,SH,WDTP,WDTE)
          WDTESU=0D0
          DO 1310 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))
 1310     CONTINUE
          IF(ISUB.EQ.135) THEN
            FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
     &      ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
          ELSE
            FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
          ENDIF
          IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=22
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQ
          ENDIF
          IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
            NCHN=NCHN+1
            ISIG(NCHN,1)=22
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQ
          ENDIF
 
        ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
          PH1=0D0
          IF(VINT(3).LT.0D0) PH1=VINT(3)**2
          PH2=0D0
          IF(VINT(4).LT.0D0) PH2=VINT(4)**2
          CALL PYWIDT(22,SH,WDTP,WDTE)
          WDTESU=0D0
          DO 1320 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))
 1320     CONTINUE
          DLAMB2=(TH+UH)**2-4D0*PH1*PH2
          IF(ISUB.EQ.137) THEN
            FPARAM=-SH*(TH+UH)/DLAMB2
            FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
     &      (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
     &      2D0*PH1*PH2*FPARAM**2)
          ELSEIF(ISUB.EQ.138) THEN
            FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
     &      PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
     &      2D0*PH1**2*(TH-UH)**2)
          ELSEIF(ISUB.EQ.139) THEN
            FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
     &      PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
     &      2D0*PH2**2*(TH-UH)**2)
          ELSE
            FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
     &      PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
          ENDIF
          IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
            NCHN=NCHN+1
            ISIG(NCHN,1)=22
            ISIG(NCHN,2)=22
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACFF
          ENDIF
 
        ENDIF
 
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 1330 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1330
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI)
            VI=AI-4D0*EI*XWV
            IA=IABS(I)
            IF(IA.LT.10) THEN
              IF(IA.LE.2) THEN
                VPI=PARU(123-2*MOD(IABS(I),2))
                API=PARU(124-2*MOD(IABS(I),2))
              ELSEIF(IA.LE.4) THEN
                VPI=PARJ(182-2*MOD(IABS(I),2))
                API=PARJ(183-2*MOD(IABS(I),2))
              ELSE
                VPI=PARJ(190-2*MOD(IABS(I),2))
                API=PARJ(191-2*MOD(IABS(I),2))
              ENDIF
            ELSE
              IF(IA.LE.12) THEN
                VPI=PARU(127-2*MOD(IABS(I),2))
                API=PARU(128-2*MOD(IABS(I),2))
              ELSEIF(IA.LE.14) THEN
                VPI=PARJ(186-2*MOD(IABS(I),2))
                API=PARJ(187-2*MOD(IABS(I),2))
              ELSE
                VPI=PARJ(194-2*MOD(IABS(I),2))
                API=PARJ(195-2*MOD(IABS(I),2))
              ENDIF
            ENDIF
            HI0=HP0
            IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
            HI1=HP1
            IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
            HI2=HP2
            IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            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))
 1330     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 1350 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1350
            IA=IABS(I)
            DO 1340 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1340
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1340
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 1340
              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
 1340       CONTINUE
 1350     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 1370 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1370
            IA=IABS(I)
            IM=(MOD(IA,10)+1)/2
            DO 1360 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1360
              JA=IABS(J)
              JM=(MOD(JA,10)+1)/2
              IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1360
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 1360
              IF(MOD(IA,2).EQ.0) THEN
                IU=IA
                IL=JA
              ELSE
                IU=JA
                IL=IA
              ENDIF
              RML=PYMRUN(IL,SH)**2/SH
              RMU=PYMRUN(IU,SH)**2/SH
              HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
              IF(IA.LE.10) HI=HI*FACA/3D0
              KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
              HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=HI*FACBW*HF
 1360       CONTINUE
 1370     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 1390 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1390
            IA=IABS(I)
            DO 1380 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1380
              JA=IABS(J)
              IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1380
              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
 1380       CONTINUE
 1390     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 1410 I=MMIN1,MMAX1
            IF(KFAC(1,I).EQ.0) GOTO 1410
            IA=IABS(I)
            IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1410
            DO 1400 J=MMIN2,MMAX2
              IF(KFAC(2,J).EQ.0) GOTO 1400
              JA=IABS(J)
              IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1400
              IF(I*J.NE.KFLQQ*KFLQL) GOTO 1400
              IF(JA.EQ.IA) GOTO 1400
              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
 1400       CONTINUE
 1410     CONTINUE
 
        ELSEIF(ISUB.EQ.146) THEN
C...e + gamma* -> e* (excited lepton)
          KFQSTR=KFPR(ISUB,1)
          KCQSTR=PYCOMP(KFQSTR)
          KFQEXC=MOD(KFQSTR,KEXCIT)
          CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
          QF=-PARU(157)/2D0-PARU(158)/2D0
          FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2
          IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
     &    FACBW=0D0
          HP=SH
          DO 1416 I=-KFQEXC,KFQEXC,2*KFQEXC
            DO 1413 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1413
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1413
              HI=HP
              IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
              IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=HI*FACBW*HF
 1413       CONTINUE
 1416     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 1430 I=-KFQEXC,KFQEXC,2*KFQEXC
            DO 1420 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1420
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1420
              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
 1420       CONTINUE
 1430     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 1440
          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
 1440     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)
          FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
C...H propagator: as simulated in PYOFSH and as desired
          SQMHC=PMAS(37,1)**2
          GMMHC=PMAS(37,1)*PMAS(37,2)
          HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
          CALL PYWIDT(37,SQM4,WDTP,WDTE)
          GMMHCC=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
          FHCQ=FHCQ*HBW4C/HBW4
          DO 1460 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.5) GOTO 1460
            SQML=PYMRUN(IA,SH)**2
            IUA=IA+MOD(IA,2)
            SQMQ=PYMRUN(IUA,SH)**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 1450 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1450
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1450
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
 1450       CONTINUE
 1460     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 1480 I=MMINA,MMAXA
            IF(IABS(I).NE.KFLQQ) GOTO 1480
            KCHLQ=ISIGN(1,I)
            DO 1470 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1470
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1470
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2)
 1470       CONTINUE
 1480     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 1490
          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
 1490     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 1500 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500
            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
 1500     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 1510 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1510
            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
 1510     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 1530 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1530
            IA=IABS(I)
            DO 1520 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1520
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1520
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 1520
              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
 1520       CONTINUE
 1530     CONTINUE
 
        ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
          KFQSTR=KFPR(ISUB,2)
          KCQSTR=PYCOMP(KFQSTR)
          KFQEXC=MOD(KFQSTR,KEXCIT)
          FACQSA=COMFAC*(SH/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 1550 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1550
            DO 1540 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1540
              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
 1540       CONTINUE
 1550     CONTINUE
 
        ELSEIF(ISUB.EQ.169) THEN
C...q + qbar -> e + e* (excited lepton)
          KFQSTR=KFPR(ISUB,2)
          KCQSTR=PYCOMP(KFQSTR)
          KFQEXC=MOD(KFQSTR,KEXCIT)
          FACQSB=(COMFAC/6D0)*(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)
          FACQSB=FACQSB*HBW4C/HBW4
          DO 1555 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1555
            J=-I
            JA=IABS(J)
            IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1555
            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
 1555     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 1560 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1560
            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
 1560     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 1580 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580
            IA=IABS(I)
            DO 1570 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1570
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 1570
              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
 1570       CONTINUE
 1580     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 1590 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1590
            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
 1590     CONTINUE
 
        ELSEIF(ISUB.EQ.194) THEN
C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech.
          KFA=KFPR(ISUBSV,1)
          ALPRHT=2.91D0*(3D0/PARP(144))
          HP=AEM**2*COMFAC
          TANW=SQRT(PARU(102)/(1D0-PARU(102)))
          CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)

          QUPD=2D0*PARP(143)-1D0
          FAR=SQRT(AEM/ALPRHT)
          FAO=FAR*QUPD
          FZR=FAR*CT2W
          FZO=-FAO*TANW
          SFAR=FAR**2
          SFAO=FAO**2
          SFZR=FZR**2
          SFZO=FZO**2
          CALL PYWIDT(23,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(54,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(56,SH,WDTP,WDTE)
          SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
          DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
     $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
          DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
          DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
          DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH

          XWRHT=1D0/(4D0*XW*(1D0-XW))
          KFF=IABS(KFPR(ISUB,1))
          EF=KCHG(KFF,1)/3D0
          AF=SIGN(1D0,EF+0.1D0)
          VF=AF-4D0*EF*XWV
          VALF=0.5D0*(VF+AF)
          VARF=0.5D0*(VF-AF)
          FCOF=1D0
          IF(KFF.LE.10) FCOF=3D0

          WID2=1D0
          IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
          IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
          DZZ=DZZ*CMPLX(XWRHT,0D0)
          DAZ=DAZ*CMPLX(SQRT(XWRHT),0D0)

          DO 1600 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            VALI=0.5D0*(VI+AI)
            VARI=0.5D0*(VI-AI)
            FCOI=FCOF
            IF(IABS(I).LE.10) FCOI=FCOI/3D0
            DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
            DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
            DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
            DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
            FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
     &      (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=HP*FCOI*FACSIG*WID2
 1600     CONTINUE

        ELSEIF(ISUB.EQ.195) THEN
C...f + fbar' -> f'' + fbar''' via s-channel rho_tech+
          KFA=KFPR(ISUBSV,1)
          KFB=KFA+1
          ALPRHT=2.91D0*(3D0/PARP(144))
          FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0

          FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
          CALL PYWIDT(24,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(55,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)

          FCOF=1D0
          IF(KFA.LE.8) FCOF=3D0
          DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
          HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF

          DO 1605 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1605
            IA=IABS(I)
            DO 1604 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1604
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1604
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 1604
              KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
              HI=HP
              IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
 1604       CONTINUE
 1605     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 1630 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630
            EI=KCHG(IA,1)/3D0
            TT3I=SIGN(1D0,EI+1D-6)/2D0
            EJ=-1D0
            TT3J=-1D0/2D0
            FCOL=1D0
C...Color factor for e+ e-
            IF(IA.GE.11) FCOL=3D0
            IF(ISUBSV.EQ.301) THEN
              A1=1D0
              A2=0D0
            ELSEIF(ILR.EQ.1) THEN
              A1=SFMIX(KFID,3)**2
              A2=SFMIX(KFID,4)**2
            ELSEIF(ILR.EQ.0) THEN
              A1=SFMIX(KFID,1)**2
              A2=SFMIX(KFID,2)**2
            ENDIF
            XLQ=(TT3J-EJ*XW)*A1
            XRQ=(-EJ*XW)*A2
            XLF=(TT3I-EI*XW)
            XRF=(-EI*XW)
            TAA=2D0*(EI*EJ)**2
            TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2
            TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
            TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1
            TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
            TNN=0.0D0
            TAN=0.0D0
            TZN=0.0D0
            IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
              FAC2=SQRT(2D0)
              TNN1=0D0
              TNN2=0D0
              TNN3=0D0
              DO 1620 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 1610 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)
 1610           CONTINUE
 1620         CONTINUE
              TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2)
              TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2
              TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
     &        (TNN1*XLF*A1+TNN2*XRF*A2)
              TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
     &        (1D0-SQMZ/SH)/SH
              TZN=TZN/XW**2/XW1
              TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW
            ENDIF
            FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
            FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
            FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQ1+FACQQ2
 1630     CONTINUE
 
        ELSEIF(ISUB.EQ.203) THEN
C...f + fbar -> e_L + e_Rbar
          DO 1660 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1660
            EI=KCHG(IABS(I),1)/3D0
            TT3I=SIGN(1D0,EI)/2D0
            EJ=-1
            TT3J=-1D0/2D0
            FCOL=1D0
C...Color factor for e+ e-
            IF(IA.GE.11) FCOL=3D0
            A1=SFMIX(KFID,1)**2
            A2=SFMIX(KFID,2)**2
            XLQ=(TT3J-EJ*XW)
            XRQ=(-EJ*XW)
            XLF=(TT3I-EI*XW)
            XRF=(-EI*XW)
            TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2
            TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
            TNN=0.0D0
            TZN=0.0D0
            IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
              FAC2=SQRT(2D0)
              TNN1=0D0
              TNN2=0D0
              TNN3=0D0
              DO 1650 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 1640 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)
 1640           CONTINUE
 1650         CONTINUE
              TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2)
              TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0
              TZN=(UH*TH-SQM3*SQM4)*A1*A2
              TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1
              TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
     &        (1D0-SQMZ/SH)/SH
            ENDIF
            FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
            FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0
            FACQQ=(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)
 1660     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 1680 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1680
            DO 1670 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1670
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1670
              FCKM=3D0
              IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
              KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
              KCHW=2
              IF(KCHSUM.LT.0) KCHW=3
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
                FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
     &          WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
              ELSE
                FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
     &          WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
              ENDIF
              SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
 1670       CONTINUE
 1680     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.220) THEN
        IF(ISUB.EQ.213) THEN
C...f + fbar -> ~nu_L + ~nu_Lbar
          IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
            FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
     &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
          ELSE
            FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
          ENDIF
          COMFAC=COMFAC*FACR
          PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ
          XLL=0.5D0
          XLR=0.0D0
          DO 1690 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1690
            EI=KCHG(IA,1)/3D0
            FCOL=1D0
C...Color factor for e+ e-
            IF(IA.GE.11) FCOL=3D0
            XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
            XRQ=-EI*XW
            TZC=0.0D0
            TCC=0.0D0
            IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
              TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
     &        (TH-SMW(2)**2)
              TCC=TZC**2
              TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL
            ENDIF
            FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ
            FACQQ2=TZC+TCC/4D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
     &      *AEM**2*FCOL/3D0/XW**2
 1690     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
          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 1700 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1700
            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/XW1
            XRQ=XRQ/XW1
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)
 1700     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 1710 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710
            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/XW1
            XRQ=XRQ/XW1
            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,2)),2)
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=-I
              ISIG(NCHN,3)=2
              SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
     &        WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
            ENDIF
 1710     CONTINUE
 
        ELSEIF(ISUB.EQ.229) THEN
C...q + qbar' -> ~chi0_1 + ~chi+-_1
          FACGG1=COMFAC*AEM**2/6D0/XW**2
          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 1730 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1730
            DO 1720 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1720
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1720
              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)
 1720       CONTINUE
 1730     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
          DO 1740 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740
            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)
 1740     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 1760 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1760
            DO 1750 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1750
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750
              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)
 1750       CONTINUE
 1760     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 1770 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1770
            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)
 1770     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 1780
          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
 1780     CONTINUE
 
        ELSEIF(ISUB.EQ.246) THEN
C...g + q_j -> ~chi0_1 + ~q_j
          FAC0=COMFAC*AS*AEM/6D0/XW
          ZM2=SQM4
          QM2=SQM3
          FACZQ0=FAC0*( (ZM2-TH)/SH +
     &    (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
     &    (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
          KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
          DO 1800 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1800
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1800
            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 1790 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1790
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1790
              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)
 1790       CONTINUE
 1800     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 1820 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1820
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1820
            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 1810 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1810
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1810
              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)
 1810       CONTINUE
 1820     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 1840 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1840
            IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1840
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
     &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
            DO 1830 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1830
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1830
              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
 1830       CONTINUE
 1840     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 1850 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1850
            IF(IA.GE.11.AND.IA.LE.18) THEN
              EI=KCHG(IA,1)/3D0
              EJ=KCHG(KFNSQ,1)/3D0
              T3I=SIGN(1D0,EI)/2D0
              T3J=SIGN(1D0,EJ)/2D0
              XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
              XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
              XLF=2D0*(T3I-EI*XW)
              XRF=2D0*(-EI*XW)
              TAA=0.5D0*(EI*EJ)**2
              TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
              TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
              TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
              TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
              FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
            ENDIF
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQ1*FAC0
 1850     CONTINUE
 
        ELSEIF(ISUB.EQ.263) THEN
C...f + fbar -> ~t1 + ~t2bar
          DO 1860 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860
            EI=KCHG(IABS(I),1)/3D0
            TT3I=SIGN(1D0,EI)/2D0
            EJ=2D0/3D0
            TT3J=1D0/2D0
            FCOL=1D0
C...Color factor for e+ e-
            IF(IA.GE.11) FCOL=3D0
            XLQ=2D0*(TT3J-EJ*XW)
            XRQ=2D0*(-EJ*XW)
            XLF=2D0*(TT3I-EI*XW)
            XRF=2D0*(-EI*XW)
            TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
            TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
            TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
C...Factor of 2 for t1 t2bar + t2 t1bar
            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)
 1860     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 1870
          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
 1870     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 1890 I=-KFNSQI,KFNSQI,2*KFNSQI
            IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1890
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1890
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            DO 1880 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
              IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1880
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1880
              IF(I*J.LT.0) GOTO 1880
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
     &        WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
              IF(I.EQ.J) THEN
                IF(ILR.EQ.0) THEN
                  SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
     &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
                ELSE
                  SIGH(NCHN)=0.5D0*FACQQ1*RKF*
     &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
     &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
                ENDIF
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=2
                IF(ILR.EQ.0) THEN
                  SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
     &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
                ELSE
                  SIGH(NCHN)=0.5D0*FACQQ2*RKF*
     &            WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
     &            WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
                ENDIF
              ENDIF
 1880       CONTINUE
 1890     CONTINUE
 
        ELSEIF(ISUB.EQ.274) THEN
C...q + qbar' -> ~q + ~qbar'
          XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
          XMT=XMG2-TH
          XMU=XMG2-UH
          IF(ILR.EQ.0) THEN
C...Mrenna...Normalization.and.1/XMT
            FACQQ1=COMFAC*AS**2*2D0/9D0*(
     &      (UH*TH-SQM3*SQM4)/XMT**2 )
            FACQQB=COMFAC*AS**2*2D0/9D0*(
     &      (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT))
            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 1910 I=-KFNSQI,KFNSQI,2*KFNSQI
            IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1910
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1910
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            DO 1900 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
              IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1900
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1900
              IF(I*J.GT.0) GOTO 1900
              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)
 1900       CONTINUE
 1910     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 1920 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 1920
            IF(IA.EQ.KFNSQ) GOTO 1920
            IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
              EI=KCHG(IA,1)/3D0
              EJ=KCHG(KFNSQ,1)/3D0
              T3J=SIGN(0.5D0,EJ)
              T3I=SIGN(1D0,EI)/2D0
              IF(ILR.EQ.0) THEN
                XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
                XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
              ELSE
                XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
                XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
              ENDIF
              XLF=2D0*(T3I-EI*XW)
              XRF=2D0*(-EI*XW)
              IF(ILR.EQ.0) THEN
                XRQ=0D0
              ELSE
                XLQ=0D0
              ENDIF
              TAA=0.5D0*(EI*EJ)**2
              TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
              TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
              TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
              TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
              FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
            ELSEIF(IA.LE.6) THEN
              FAC0=AS**2*8D0/9D0/2D0
            ENDIF
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
 1920     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 1930
          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)
 1930     CONTINUE
 
        ENDIF
CMRENNA--
        
      ELSEIF(ISUB.LE.340) THEN 

      ELSEIF(ISUB.LE.360) THEN

        IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
C...l + l -> H_L++/-- or H_R++/--.
          KFRES=KFPR(ISUB,1)
          CALL PYWIDT(KFRES,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=8D0*COMFAC/((SH-PMAS(KFRES,1)**2)**2+HS**2)
          DO 1950 I=MMIN1,MMAX1
            IA=IABS(I)
            IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0) 
     &      GOTO 1950
            DO 1940 J=MMIN2,MMAX2
              JA=IABS(J)
              IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0) 
     &        GOTO 1940
              IF(I*J.LT.0) GOTO 1940
              KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
              HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
              SIGH(NCHN)=HI*FACBW*HF
 1940       CONTINUE
 1950     CONTINUE

        ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
          KFRES=KFPR(ISUB,1)
C...Propagators: as simulated in PYOFSH and as desired
          HBW3=PMAS(KFRES,1)*PMAS(KFRES,2)/((SQM3-PMAS(KFRES,1)**2)**2+
     &    (PMAS(KFRES,1)*PMAS(KFRES,2))**2)
          CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
          GMMC=SQRT(SQM3)*WDTP(0)
          HBW3C=GMMC/((SQM3-PMAS(KFRES,1)**2)**2+GMMC**2)
          FHCC=COMFAC*AEM*HBW3C/HBW3
          DO 1980 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 1980
            SQML=PMAS(IA,1)**2
            J=ISIGN(KFPR(ISUB,2),-I)
            KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
            WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
            SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
     &      (UH-SQM3)**2
            SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
     &      (TH-SQM4)*SH)/(TH-SQM4)**2 
            SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
     &      SH)/(SH-SQML)**2
            SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
     &      3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
     &      ((UH-SQM3)*(TH-SQM4))
            SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
     &      SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
     &      ((UH-SQM3)*(SH-SQML))
            SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
     &      3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
     &      ((SH-SQML)*(TH-SQM4))
            SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
     &      PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
            DO 1960 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1960
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1960
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=0
              SIGH(NCHN)=FHCC*SMM*WIDSC
 1960       CONTINUE
 1980     CONTINUE
 
        ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
          KFRES=KFPR(ISUB,1)
          SQMH=PMAS(KFRES,1)**2
          GMMH=PMAS(KFRES,1)*PMAS(KFRES,2)
C...Propagators: H++/-- as simulated in PYOFSH and as desired
          HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
          CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
          GMMH3=SQRT(SQM3)*WDTP(0)
          HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
          HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
          CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
          GMMH4=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
C...Kinematical and coupling functions
          FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
          XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))         
C...Loop over allowed flavours
          DO 2000 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2000
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            FCOI=1D0
            IF(IABS(I).LE.10) FCOI=FACA/3D0
            IF(ISUB.EQ.349) THEN
              HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
              IF(IABS(I).LT.10) THEN
                DSIGHH=8D0*AEM**2*(EI**2/SH2+
     &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
     &          (VI**2+AI**2)*XWHH**2*HBWZ)
              ELSE 
                IAOFF=181+3*((IABS(I)-11)/2)
                HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
     &          (4D0*PARU(1))
                DSIGHH=8D0*AEM**2*(EI**2/SH2+
     &          2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
     &          (VI**2+AI**2)*XWHH**2*HBWZ)+
     &          8D0*AEM*(EI*HSUM/(SH*TH)+
     &          (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
     &          4D0*HSUM**2/TH2
              ENDIF
            ELSE
              IF(IABS(I).LT.10) THEN
                DSIGHH=8D0*AEM**2*EI**2/SH2
              ELSE 
                IAOFF=181+3*((IABS(I)-11)/2)
                HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
     &          (4D0*PARU(1))
                DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
     &          4D0*HSUM**2/TH2 
              ENDIF     
            ENDIF
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACHH*FCOI*DSIGHH
 2000     CONTINUE
 
        ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
          KFRES=KFPR(ISUB,1)
          SQMH=PMAS(KFRES,1)**2
          IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
          IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*PMAS(63,1)**2
          FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
          FACPRT=1D0/((VINT(204)**2-VINT(215))*
     &    (VINT(209)**2-VINT(216)))
          FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
     &    (VINT(209)**2+2D0*VINT(218)))
          CALL PYWIDT(KFRES,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
          IF(ABS(SHR-PMAS(KFRES,1)).GT.PARP(48)*PMAS(KFRES,2))
     &    FACBW=0D0
          DO 2020 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2020
            IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2020
            KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)  
            DO 2010 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2010
              IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2010
              KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
              KCHH=KCHWI+KCHWJ
              IF(IABS(KCHH).NE.2) GOTO 2010  
              FACLR=VINT(180+I)*VINT(180+J)
              HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
              IF(I.EQ.J.AND.IABS(I).GT.10) THEN
                FACPRP=0.5D0*(FACPRT+FACPRU)**2
              ELSE
                FACPRP=FACPRT**2
              ENDIF 
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
 2010       CONTINUE
 2020     CONTINUE
        ENDIF

      ELSEIF(ISUB.LE.380) THEN
 
        IF(ISUB.EQ.361) THEN
C...f + fbar -> W_L W_L, W_L pi_tech, pi_tech pi_tech
          FACA=(SH**2*BE34**2-(TH-UH)**2)
          ALPRHT=2.91D0*(3D0/PARP(144))
          HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0
          FAR=SQRT(AEM/ALPRHT)
          FAO=FAR*QUPD
          FZR=FAR*CT2W
          FZO=-FAO*TANW
          SFAR=FAR**2
          SFAO=FAO**2
          SFZR=FZR**2
          SFZO=FZO**2
          CALL PYWIDT(23,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(54,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(56,SH,WDTP,WDTE)
          SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
          DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
     $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
          DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
          DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH

          DO 2040 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2040
            IA=IABS(I)
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            VALI=0.25D0*(VI+AI)
            VARI=0.25D0*(VI-AI)
            F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1)
            F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1)
            HI=ABS(F2L)**2+ABS(F2R)**2
            IF(IA.LE.10) HI=HI/3D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            IF(KFA.EQ.KFB) THEN
               SIGH(NCHN)=HI*HP*WIDS(KFA,1)
            ELSE
               SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=-I
               ISIG(NCHN,3)=2
               SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
            ENDIF
 2040     CONTINUE

        ELSEIF(ISUB.EQ.364) THEN
C...f + fbar -> gamma pi_tech, gamma pi_tech', Z pi_tech, Z pi_tech', 
C...W pi_tech
          VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH
          AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH

          ALPRHT=2.91D0*(3D0/PARP(144))
          HP=(1D0/24D0)*AEM**2*COMFAC*3D0
          FAR=SQRT(AEM/ALPRHT)
          FAO=FAR*QUPD
          FZR=FAR*CT2W
          FZO=-FAO*TANW
          SFAR=FAR**2
          SFAO=FAO**2
          SFZR=FZR**2
          SFZO=FZO**2
          CALL PYWIDT(23,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(54,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(54,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(56,SH,WDTP,WDTE)
          SSMO=CMPLX(1D0-PMAS(56,1)**2/SH,WDTP(0)/SHR)
          DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
     $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
          DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
          DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
          DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
          DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH

          DO 2060 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2060
            IA=IABS(I)
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI+0.1D0)
            VI=AI-4D0*EI*XWV
            VALI=0.25D0*(VI+AI)
            VARI=0.25D0*(VI-AI)
            F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
            F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
            F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
            F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
            HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
            F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
            F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
            F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
            F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
            HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
            HI=HI+HJ
            IF(IA.LE.10) HI=HI/3D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            IF(ISUBSV.NE.368) THEN
               SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,2)
            ELSE
               SIGH(NCHN)=HI*HP*WIDS(KFA,2)*WIDS(KFB,3)
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=-I
               ISIG(NCHN,3)=2
               SIGH(NCHN)=HI*HP*WIDS(KFA,3)*WIDS(KFB,2)
            ENDIF
 2060     CONTINUE

        ELSEIF(ISUB.EQ.370) THEN
C...f + fbar' -> W_L Z_L, W_L pi_tech, Z_L pi_tech, pi_tech pi_tech

          FACA=(SH**2*BE34**2-(TH-UH)**2)
          ALPRHT=2.91D0*(3D0/PARP(144))
          HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW

          FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
          CALL PYWIDT(24,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(55,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)

          DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
          HP=HP*FWR**2/ABS(DETD)**2/SH**2

          DO 2080 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2080
            IA=IABS(I)
            DO 2070 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2070
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2070
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 2070
              KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
              HI=HP
              IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
 2070       CONTINUE
 2080     CONTINUE

        ELSEIF(ISUB.EQ.374) THEN
C...f + fbar' -> G pi_tech
          VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2
          AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2

          ALPRHT=2.91D0*(3D0/PARP(144))
          HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH

          FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
          CALL PYWIDT(24,SH,WDTP,WDTE)
          SSMZ=CMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(55,SH,WDTP,WDTE)
          SSMR=CMPLX(1D0-PMAS(55,1)**2/SH,WDTP(0)/SHR)

          DETD=SSMZ*SSMR-CMPLX(FWR**2,0D0)
          HP=HP*FWR**2/ABS(DETD)**2/SH**2

          DO 2100 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2100
            IA=IABS(I)
            DO 2090 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2090
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2090
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 2090
              KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
              HI=HP
              IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,2)
 2090       CONTINUE
 2100     CONTINUE
 
        ENDIF
      ENDIF
 
C...Multiply with parton distributions
      IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
        DO 2200 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)
 2200   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPDFU
C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
C...parton distributions according to a few different parametrizations.
C...Note that what is coded is x times the probability distribution,
C...i.e. xq(x,Q2) etc.
 
      SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/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.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
     &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
     &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
     &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111) THEN
        WRITE(MSTU(11),5100) KF
        RETURN
      ENDIF
 
C...Electron (or muon or tau) parton distribution call.
      IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
        CALL PYPDEL(KFA,X,Q2,XPEL)
        DO 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
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,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
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,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
          QQ2=MAX(0D0,Q2MIN,Q2)
          IF(MSTP(57).EQ.0) QQ2=Q2MIN
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          IP2=MSTP(60)
          IF(MSTP(55).EQ.5004) THEN
            IF(5D0*P2.LT.QQ2.AND.
     &      QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
     &      P2.GE.0D0.AND.P2.LT.10D0.AND.
     &      XX.GT.1D-4.AND.XX.LT.1D0) THEN
              CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
     &        BOT,TOP,GLU)
            ELSE
              UPV=0D0
              DNV=0D0
              USEA=0D0
              DSEA=0D0
              STR=0D0
              CHM=0D0
              BOT=0D0
              TOP=0D0
              GLU=0D0
            ENDIF
          ELSE
            IF(P2.LT.QQ2) THEN
              CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
     &        BOT,TOP,GLU)
            ELSE
              UPV=0D0
              DNV=0D0
              USEA=0D0
              DSEA=0D0
              STR=0D0
              CHM=0D0
              BOT=0D0
              TOP=0D0
              GLU=0D0
            ENDIF
          ENDIF
          VINT(231)=Q2MIN
          XPQ(0)=GLU
          XPQ(1)=DNV
          XPQ(-1)=DNV
          XPQ(2)=UPV
          XPQ(-2)=UPV
          XPQ(3)=STR
          XPQ(-3)=STR
          XPQ(4)=CHM
          XPQ(-4)=CHM
          XPQ(5)=BOT
          XPQ(-5)=BOT
          XPQ(6)=TOP
          XPQ(-6)=TOP
        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
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
          DO 150 KFL=-6,6
            XPQ(KFL)=XPVMD(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
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
          DO 170 KFL=-6,6
            XPQ(KFL)=XPANL(KFL)+XPANH(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
          P2=0D0
          IF(VINT(120).LT.0D0) P2=VINT(120)**2
          CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,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.20) 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.
C+++Do not rescale?
        IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
     &  .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
          DO 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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
      DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
 
C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
      MINT(92)=0
      KFA=IABS(KF)
      IACC=0
      IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
      IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
      IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
      IF(IACC.EQ.0) THEN
        CALL PYPDFU(KF,X,Q2,XPQ)
        RETURN
      ENDIF
 
C...Reset. Check x.
      DO 100 KFL=-25,25
        XPQ(KFL)=0D0
  100 CONTINUE
      IF(X.LE.0D0.OR.X.GE.1D0) THEN
        WRITE(MSTU(11),5000) X
        RETURN
      ENDIF
 
C...Define valence content.
      KFC=KF
      NV1=2
      NV2=1
      IF(KF.EQ.2212) THEN
        KFV1=2
        KFV2=1
      ELSEIF(KF.EQ.-2212) THEN
        KFV1=-2
        KFV2=-1
      ELSEIF(KF.EQ.2112) THEN
        KFV1=1
        KFV2=2
      ELSEIF(KF.EQ.-2112) THEN
        KFV1=-1
        KFV2=-2
      ELSEIF(KF.EQ.211) THEN
        NV1=1
        KFV1=2
        KFV2=-1
      ELSEIF(KF.EQ.-211) THEN
        NV1=1
        KFV1=-2
        KFV2=1
      ELSEIF(MINT(105).LE.223) THEN
        KFV1=1
        WTV1=0.2D0
        KFV2=2
        WTV2=0.8D0
      ELSEIF(MINT(105).EQ.333) THEN
        KFV1=3
        WTV1=1.0D0
        KFV2=1
        WTV2=0.0D0
      ELSEIF(MINT(105).EQ.443) THEN
        KFV1=4
        WTV1=1.0D0
        KFV2=1
        WTV2=0.0D0
      ENDIF
 
C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
      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 (or muon, or tau) parton distribution.
 
      SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
 
C...Interface to PDFLIB.
      COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
      SAVE /W50513/
      DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
     &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
      CHARACTER*20 PARM(20)
      DATA VALUE/20*0D0/,PARM/20*' '/
 
C...Some common constants.
      DO 100 KFL=-25,25
        XPEL(KFL)=0D0
  100 CONTINUE
      AEM=PARU(101)
      PME=PMAS(11,1)
      IF(KFA.EQ.13) PME=PMAS(13,1)
      IF(KFA.EQ.15) PME=PMAS(15,1)
      XL=LOG(MAX(1D-10,X))
      X1L=LOG(MAX(1D-10,1D0-X))
      HLE=LOG(MAX(3D0,Q2/PME**2))
      HBE2=(AEM/PARU(1))*(HLE-1D0)
 
C...Electron inside electron, see R. Kleiss et al., in Z physics at
C...LEP 1, CERN 89-08, p. 34
      IF(MSTP(59).LE.1) THEN
        HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
     &  (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
        HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
     &  0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
     &  4D0*XL/(1D0-X)-5D0-X)
      ELSE
        HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
     &  PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
     &  (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
      ENDIF
C...Zero distribution for very large x and rescale it for intermediate.
      IF(X.GT.1D0-1D-10) THEN
        HEE=0D0
      ELSEIF(X.GT.1D0-1D-7) THEN
        HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
      ENDIF
      XPEL(KFA)=X*HEE
 
C...Photon and (transverse) W- inside electron.
      AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
      IF(MSTP(13).LE.1) THEN
        HLG=HLE
      ELSE
        HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
      ENDIF
      XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
      HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
      XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
 
C...Electron or positron inside photon inside electron.
      IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
        XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
     &  2D0*X*(1D0+X)*XL)
        XPEL(11)=XPEL(11)+XFSEA
        XPEL(-11)=XFSEA
 
C...Initialize PDFLIB photon parton distributions.
        IF(MSTP(56).EQ.2) THEN
          PARM(1)='NPTYPE'
          VALUE(1)=3
          PARM(2)='NGROUP'
          VALUE(2)=MSTP(55)/1000
          PARM(3)='NSET'
          VALUE(3)=MOD(MSTP(55),1000)
          IF(MINT(93).NE.3000000+MSTP(55)) THEN
            CALL PDFSET(PARM,VALUE)
            MINT(93)=3000000+MSTP(55)
          ENDIF
        ENDIF
 
C...Quarks and gluons inside photon inside electron:
C...numerical convolution required.
        DO 110 KFL=0,6
          SXP(KFL)=0D0
  110   CONTINUE
        SUMXPP=0D0
        ITER=-1
  120   ITER=ITER+1
        SUMXP=SUMXPP
        NSTP=2**(ITER-1)
        IF(ITER.EQ.0) NSTP=2
        DO 130 KFL=0,6
          SXP(KFL)=0.5D0*SXP(KFL)
  130   CONTINUE
        WTSTP=0.5D0/NSTP
        IF(ITER.EQ.0) WTSTP=0.5D0
C...Pick grid of x_{gamma} values logarithmically even.
        DO 150 ISTP=1,NSTP
          IF(ITER.EQ.0) THEN
            XLE=XL*(ISTP-1)
          ELSE
            XLE=XL*(ISTP-0.5D0)/NSTP
          ENDIF
          XE=MIN(1D0-1D-10,EXP(XLE))
          XG=MIN(1D0-1D-10,X/XE)
C...Evaluate photon inside electron parton distribution for convolution.
          XPGP=1D0+(1D0-XE)**2
          IF(MSTP(13).LE.1) THEN
            XPGP=XPGP*HLE
          ELSE
            XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
          ENDIF
C...Evaluate photon parton distributions for convolution.
          IF(MSTP(56).EQ.1) THEN
            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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
     &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
     &DGCS(4,3),DGDS(4,3),DGES(4,3)
 
C...The following data lines are coefficients needed in the
C...Drees and Grassie photon parton distribution parametrization.
      DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
     &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
      DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
     &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
      DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
     &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
      DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
     &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
      DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
     &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
      DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
     &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
      DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
     &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
      DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
     &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
      DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
     &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
      DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
     &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
      DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
     &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
      DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
     &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
      DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
     &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
 
C...Photon parton distribution from Drees and Grassie.
C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
      DO 100 KFL=-6,6
        XPGA(KFL)=0D0
  100 CONTINUE
      VINT(231)=1D0
      IF(MSTP(57).LE.0) THEN
        T=LOG(1D0/0.16D0)
      ELSE
        T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
      ENDIF
      X1=1D0-X
      NF=3
      IF(Q2.GT.25D0) NF=4
      IF(Q2.GT.300D0) NF=5
      NFE=NF-2
      AEM=PARU(101)
 
C...Evaluate gluon content.
      DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
      DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
      DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
      XPGL=DGA*X**DGB*X1**DGC
 
C...Evaluate up- and down-type quark content.
      DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
      DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
      DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
      DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
      DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
      XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
      DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
      DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
      DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
      DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
      DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
      DGF=9D0
      IF(NF.EQ.4) DGF=10D0
      IF(NF.EQ.5) DGF=55D0/6D0
      XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
      IF(NF.LE.3) THEN
        XPQU=(XPQS+9D0*XPQN)/6D0
        XPQD=(XPQS-4.5D0*XPQN)/6D0
      ELSEIF(NF.EQ.4) THEN
        XPQU=(XPQS+6D0*XPQN)/8D0
        XPQD=(XPQS-6D0*XPQN)/8D0
      ELSE
        XPQU=(XPQS+7.5D0*XPQN)/10D0
        XPQD=(XPQS-5D0*XPQN)/10D0
      ENDIF
 
C...Put into output arrays.
      XPGA(0)=AEM*XPGL
      XPGA(1)=AEM*XPQD
      XPGA(2)=AEM*XPQU
      XPGA(3)=AEM*XPQD
      IF(NF.GE.4) XPGA(4)=AEM*XPQU
      IF(NF.GE.5) XPGA(5)=AEM*XPQD
      DO 110 KFL=1,6
        XPGA(-KFL)=XPGA(KFL)
  110 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGGAM
C...Constructs the F2 and parton distributions of the photon
C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
C...For F2, c and b are included by the Bethe-Heitler formula;
C...in the 'MSbar' scheme additionally a Cgamma term is added.
C...Contains the SaS sets 1D, 1M, 2D and 2M.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
 
      SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
     &XPDIR(-6:6)
      COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
      SAVE /PYINT8/,/PYINT9/
C...Local arrays.
      DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
C...Charm and bottom masses (low to compensate for J/psi etc.).
      DATA PMC/1.3D0/, PMB/4.6D0/
C...alpha_em and alpha_em/(2*pi).
      DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
C...Lambda value for 4 flavours.
      DATA ALAM/0.20D0/
C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
      DATA FRACU/0.8D0/
C...VMD couplings f_V**2/(4*pi).
      DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
C...Masses for rho (=omega) and phi.
      DATA PMRHO/0.770D0/, PMPHI/1.020D0/
C...Number of points in integration for IP2=1.
      DATA NSTEP/100/
 
C...Reset output.
      F2GM=0D0
      DO 100 KFL=-6,6
        XPDFGM(KFL)=0D0
        XPVMD(KFL)=0D0
        XPANL(KFL)=0D0
        XPANH(KFL)=0D0
        XPBEH(KFL)=0D0
        XPDIR(KFL)=0D0
        VXPVMD(KFL)=0D0
        VXPANL(KFL)=0D0
        VXPANH(KFL)=0D0
        VXPDGM(KFL)=0D0
  100 CONTINUE
 
C...Set Q0 cut-off parameter as function of set used.
      IF(ISET.LE.2) THEN
        Q0=0.6D0
      ELSE
        Q0=2D0
      ENDIF
      Q02=Q0**2
 
C...Scale choice for off-shell photon; common factors.
      Q2A=Q2
      FACNOR=1D0
      IF(IP2.EQ.1) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
        FACNOR=LOG(Q2/Q02)/NSTEP
      ELSEIF(IP2.EQ.2) THEN
        P2MX=MAX(P2,Q02)
      ELSEIF(IP2.EQ.3) THEN
        P2MX=P2+Q02
        Q2A=Q2+P2*Q02/MAX(Q02,Q2)
      ELSEIF(IP2.EQ.4) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
      ELSEIF(IP2.EQ.5) THEN
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
      ELSEIF(IP2.EQ.6) THEN
        P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
      ELSE
        P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
     &  ((Q2+P2)*(Q02+P2)))
        P2MX=Q0*SQRT(P2MXA)
        P2MXB=P2MX
        P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
        P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
        IF(ABS(Q2-Q02).GT.1D-6) THEN
          FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
        ELSEIF(P2.LT.Q02) THEN
          FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
        ELSE
          FACNOR=1D0
        ENDIF
      ENDIF
 
C...Call VMD parametrization for d quark and use to give rho, omega,
C...phi. Note dipole dampening for off-shell photon.
      CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
      XFVAL=VXPGA(1)
      XPGA(1)=XPGA(2)
      XPGA(-1)=XPGA(-2)
      FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
      FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
      DO 110 KFL=-5,5
        XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
  110 CONTINUE
      XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
      XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
      XPVMD(3)=XPVMD(3)+FACS*XFVAL
      XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
      XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
      XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
      VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
      VXPVMD(2)=FRACU*FACUD*XFVAL
      VXPVMD(3)=FACS*XFVAL
      VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
      VXPVMD(-2)=FRACU*FACUD*XFVAL
      VXPVMD(-3)=FACS*XFVAL
 
      IF(IP2.NE.1) THEN
C...Anomalous parametrizations for different strategies
C...for off-shell photons; except full integration.
 
C...Call anomalous parametrization for d + u + s.
        CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 120 KFL=-5,5
          XPANL(KFL)=FACNOR*XPGA(KFL)
          VXPANL(KFL)=FACNOR*VXPGA(KFL)
  120   CONTINUE
 
C...Call anomalous parametrization for c and b.
        CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 130 KFL=-5,5
          XPANH(KFL)=FACNOR*XPGA(KFL)
          VXPANH(KFL)=FACNOR*VXPGA(KFL)
  130   CONTINUE
        CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
        DO 140 KFL=-5,5
          XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
          VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
  140   CONTINUE
 
      ELSE
C...Special option: loop over flavours and integrate over k2.
        DO 170 KF=1,5
          DO 160 ISTEP=1,NSTEP
            Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
            IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
     &      (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
            CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
            FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
            IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
            IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
            DO 150 KFL=-5,5
              IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
              IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
              IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
              IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
  150       CONTINUE
  160     CONTINUE
  170   CONTINUE
      ENDIF
 
C...Call Bethe-Heitler term expression for charm and bottom.
      CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
      XPBEH(4)=XPBH
      XPBEH(-4)=XPBH
      CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
      XPBEH(5)=XPBH
      XPBEH(-5)=XPBH
 
C...For MSbar subtraction call C^gamma term expression for d, u, s.
      IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
        CALL PYGDIR(X,Q2,P2,Q02,XPGA)
        DO 180 KFL=-5,5
          XPDIR(KFL)=XPGA(KFL)
  180   CONTINUE
      ENDIF
 
C...Store result in output array.
      DO 190 KFL=-5,5
        CHSQ=1D0/9D0
        IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
        XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
        IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
        XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
        VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
  190 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGVMD
C...Evaluates the VMD parton distributions of a photon,
C...evolved homogeneously from an initial scale P2 to Q2.
C...Does not include dipole suppression factor.
C...ISET is parton distribution set, see above;
C...additionally ISET=0 is used for the evolution of an anomalous photon
C...which branched at a scale P2 and then evolved homogeneously to Q2.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
 
      SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Local arrays and data.
      DIMENSION XPGA(-6:6), VXPGA(-6:6)
      DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
 
C...Reset output.
      DO 100 KFL=-6,6
        XPGA(KFL)=0D0
        VXPGA(KFL)=0D0
  100 CONTINUE
      KFA=IABS(KF)
 
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
      ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
      P2EFF=MAX(P2,1.2D0*ALAM3**2)
      IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)
 
C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5
 
C...Find s as sum of 3-, 4- and 5-flavour parts.
      S=0D0
      IF(NFP.EQ.3) THEN
        Q2DIV=PMC**2
        IF(NFQ.EQ.3) Q2DIV=Q2EFF
        S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
      ENDIF
      IF(NFP.LE.4.AND.NFQ.GE.4) THEN
        P2DIV=P2EFF
        IF(NFP.EQ.3) P2DIV=PMC**2
        Q2DIV=Q2EFF
        IF(NFQ.EQ.5) Q2DIV=PMB**2
        S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
      ENDIF
      IF(NFQ.EQ.5) THEN
        P2DIV=PMB**2
        IF(NFP.EQ.5) P2DIV=P2EFF
        S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
      ENDIF
 
C...Calculate frequent combinations of x and s.
      X1=1D0-X
      XL=-LOG(X)
      S2=S**2
      S3=S**3
      S4=S**4
 
C...Evaluate homogeneous anomalous parton distributions below or
C...above threshold.
      IF(ISET.EQ.0) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = X * 1.5D0 * (X**2+X1**2)
          XGLU = 0D0
          XSEA = 0D0
        ELSE
          XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
     &    (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
     &    5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
     &    X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
          XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
     &    X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
     &    ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
          XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
     &    X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
     &    ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
     &    (2D0*X-1D0)*X*XL**2)
        ENDIF
 
C...Evaluate set 1D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.1) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
          XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
          XSEA = 0.100D0 * X1**3.76D0
        ELSE
          XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
     &    X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
          XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
     &    X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
     &    XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
     &    X**0.40D0 * X1**(1.76D0+3D0*S)
          XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
     &    (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
     &    X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
          XSEA0 = 0.100D0 * X1**3.76D0
        ENDIF
 
C...Evaluate set 1M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.2) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
          XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
          XSEA = 0D0
        ELSE
          XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
     &    X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
          XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
     &    EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
     &    X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
     &    EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
          XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
     &    X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
     &    XL**(2.8D0*S)
          XSEA0 = 0D0
        ENDIF
 
C...Evaluate set 2D parton distributions below or above threshold.
      ELSEIF(ISET.EQ.3) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
          XGLU = 1.925D0 * X1**2
          XSEA = 0.242D0 * X1**4
        ELSE
          XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
     &    X**(0.46D0+0.25D0*S) *
     &    X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
     &    (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
          XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
     &    EXP(-18.67D0*S) *
     &    X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
     &    * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
     &    XL**(9.3D0*S/(1D0+1.7D0*S))
          XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
     &    (1D0-0.607D0*S+21.95D0*S2) *
     &    X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
          XSEA0 = 0.242D0 * X1**4
        ENDIF
 
C...Evaluate set 2M parton distributions below or above threshold.
      ELSEIF(ISET.EQ.4) THEN
        IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
     &  (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
          XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
          XGLU = 1.808D0 * X1**2
          XSEA = 0.209D0 * X1**4
        ELSE
          XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
     &    X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
     &    X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
     &    XL**(5.15D0*S/(1D0+2D0*S)) +
     &    (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
          XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
     &    X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
     &    X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
     &    XL**(10.9D0*S/(1D0+2.5D0*S))
          XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
     &    X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
     &    X1**(4D0+S) * XL**(0.45D0*S)
          XSEA0 = 0.209D0 * X1**4
        ENDIF
      ENDIF
 
C...Threshold factors for c and b sea.
      SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
      XCHM=0D0
      IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
        SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XCHM=XSEA*(1D0-(SCH/SLL)**2)
        ELSE
          XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
        ENDIF
      ENDIF
      XBOT=0D0
      IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
        SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
        IF(ISET.EQ.0) THEN
          XBOT=XSEA*(1D0-(SBT/SLL)**2)
        ELSE
          XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
        ENDIF
      ENDIF
 
C...Fill parton distributions.
      XPGA(0)=XGLU
      XPGA(1)=XSEA
      XPGA(2)=XSEA
      XPGA(3)=XSEA
      XPGA(4)=XCHM
      XPGA(5)=XBOT
      XPGA(KFA)=XPGA(KFA)+XVAL
      DO 110 KFL=1,5
        XPGA(-KFL)=XPGA(KFL)
  110 CONTINUE
      VXPGA(KFA)=XVAL
      VXPGA(-KFA)=XVAL
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGANO
C...Evaluates the parton distributions of the anomalous photon,
C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
C...KF=0 gives the sum over (up to) 5 flavours,
C...KF<0 limits to flavours up to abs(KF),
C...KF>0 is for flavour KF only.
C...ALAM is the 4-flavour Lambda, which is automatically converted
C...to 3- and 5-flavour equivalents as needed.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
 
      SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Local arrays and data.
      DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
      DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
 
C...Reset output.
      DO 100 KFL=-6,6
        XPGA(KFL)=0D0
        VXPGA(KFL)=0D0
  100 CONTINUE
      IF(Q2.LE.P2) RETURN
      KFA=IABS(KF)
 
C...Calculate Lambda; protect against unphysical Q2 and P2 input.
      ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
      ALAMSQ(4)=ALAM**2
      ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
      P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
      IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
      IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
      Q2EFF=MAX(Q2,P2EFF)
      XL=-LOG(X)
 
C...Find number of flavours at lower and upper scale.
      NFP=4
      IF(P2EFF.LT.PMC**2) NFP=3
      IF(P2EFF.GT.PMB**2) NFP=5
      NFQ=4
      IF(Q2EFF.LT.PMC**2) NFQ=3
      IF(Q2EFF.GT.PMB**2) NFQ=5
 
C...Define range of flavour loop.
      IF(KF.EQ.0) THEN
        KFLMN=1
        KFLMX=5
      ELSEIF(KF.LT.0) THEN
        KFLMN=1
        KFLMX=KFA
      ELSE
        KFLMN=KFA
        KFLMX=KFA
      ENDIF
 
C...Loop over flavours the photon can branch into.
      DO 110 KFL=KFLMN,KFLMX
 
C...Light flavours: calculate t range and (approximate) s range.
        IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
          TDIFF=LOG(Q2EFF/P2EFF)
          S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          IF(NFQ.GT.NFP) THEN
            Q2DIV=PMB**2
            IF(NFQ.EQ.4) Q2DIV=PMC**2
            SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &      LOG(P2EFF/ALAMSQ(NFQ)))
            SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &      LOG(P2EFF/ALAMSQ(NFQ-1)))
            S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
          ENDIF
          IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
            Q2DIV=PMC**2
            SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
     &      LOG(P2EFF/ALAMSQ(4)))
            SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
     &      LOG(P2EFF/ALAMSQ(3)))
            S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
          ENDIF
 
C...u and s quark do not need a separate treatment when d has been done.
        ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
 
C...Charm: as above, but only include range above c threshold.
        ELSEIF(KFL.EQ.4) THEN
          IF(Q2.LE.PMC**2) GOTO 110
          P2EFF=MAX(P2EFF,PMC**2)
          Q2EFF=MAX(Q2EFF,P2EFF)
          TDIFF=LOG(Q2EFF/P2EFF)
          S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
          IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
            Q2DIV=PMB**2
            SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
     &      LOG(P2EFF/ALAMSQ(NFQ)))
            SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
     &      LOG(P2EFF/ALAMSQ(NFQ-1)))
            S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
          ENDIF
 
C...Bottom: as above, but only include range above b threshold.
        ELSEIF(KFL.EQ.5) THEN
          IF(Q2.LE.PMB**2) GOTO 110
          P2EFF=MAX(P2EFF,PMB**2)
          Q2EFF=MAX(Q2,P2EFF)
          TDIFF=LOG(Q2EFF/P2EFF)
          S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
     &    LOG(P2EFF/ALAMSQ(NFQ)))
        ENDIF
 
C...Evaluate flavour-dependent prefactor (charge^2 etc.).
        CHSQ=1D0/9D0
        IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
        FAC=AEM2PI*2D0*CHSQ*TDIFF
 
C...Evaluate parton distributions (normalized to unit momentum sum).
        IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
          XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
     &    (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
     &    1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
     &    X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
          XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
     &    X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
     &    ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
          XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
     &    X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
     &    ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
     &    (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
 
C...Threshold factors for c and b sea.
          SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
          XCHM=0D0
          IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
            SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
            XCHM=XSEA*(1D0-(SCH/SLL)**3)
          ENDIF
          XBOT=0D0
          IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
            SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
            XBOT=XSEA*(1D0-(SBT/SLL)**3)
          ENDIF
        ENDIF
 
C...Add contribution of each valence flavour.
        XPGA(0)=XPGA(0)+FAC*XGLU
        XPGA(1)=XPGA(1)+FAC*XSEA
        XPGA(2)=XPGA(2)+FAC*XSEA
        XPGA(3)=XPGA(3)+FAC*XSEA
        XPGA(4)=XPGA(4)+FAC*XCHM
        XPGA(5)=XPGA(5)+FAC*XBOT
        XPGA(KFL)=XPGA(KFL)+FAC*XVAL
        VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
  110 CONTINUE
      DO 120 KFL=1,5
        XPGA(-KFL)=XPGA(KFL)
        VXPGA(-KFL)=VXPGA(KFL)
  120 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGBEH
C...Evaluates the Bethe-Heitler cross section for heavy flavour
C...production.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
 
      SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local data.
      DATA AEM2PI/0.0011614D0/
 
C...Reset output.
      XPBH=0D0
      SIGBH=0D0
 
C...Check kinematics limits.
      IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
      W2=Q2*(1D0-X)/X-P2
      BETA2=1D0-4D0*PM2/W2
      IF(BETA2.LT.1D-10) RETURN
      BETA=SQRT(BETA2)
      RMQ=4D0*PM2/Q2
 
C...Simple case: P2 = 0.
      IF(P2.LT.1D-4) THEN
        IF(BETA.LT.0.99D0) THEN
          XBL=LOG((1D0+BETA)/(1D0-BETA))
        ELSE
          XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
        ENDIF
        SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
     &  XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
 
C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
      ELSE
        RPQ=1D0-4D0*X**2*P2/Q2
        IF(RPQ.GT.1D-10) THEN
          RPBE=SQRT(RPQ*BETA2)
          IF(RPBE.LT.0.99D0) THEN
            XBL=LOG((1D0+RPBE)/(1D0-RPBE))
            XBI=2D0*RPBE/(1D0-RPBE**2)
          ELSE
            RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
            XBL=LOG((1D0+RPBE)**2/RPBESN)
            XBI=2D0*RPBE/RPBESN
          ENDIF
          SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
     &    XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
     &    XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
        ENDIF
      ENDIF
 
C...Multiply by charge-squared etc. to get parton distribution.
      CHSQ=1D0/9D0
      IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
      XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGDIR
C...Evaluates the direct contribution, i.e. the C^gamma term,
C...as needed in MSbar parametrizations.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
 
      SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Local array and data.
      DIMENSION XPGA(-6:6)
      DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
 
C...Reset output.
      DO 100 KFL=-6,6
        XPGA(KFL)=0D0
  100 CONTINUE
 
C...Evaluate common x-dependent expression.
      XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
      CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
 
C...d, u, s part by simple charge factor.
      XPGA(1)=(1D0/9D0)*CGAM
      XPGA(2)=(4D0/9D0)*CGAM
      XPGA(3)=(1D0/9D0)*CGAM
 
C...Also fill for antiquarks.
      DO 110 KF=1,5
        XPGA(-KF)=XPGA(KF)
  110 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPDPI
C...Gives pi+ parton distribution according to two different
C...parametrizations.
 
      SUBROUTINE PYPDPI(X,Q2,XPPI)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
 
C...The following data lines are coefficients needed in the
C...Owens pion parton distribution parametrizations, see below.
C...Expansion coefficients for up and down valence quark distributions.
      DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
     &4.0000D-01,  7.0000D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
     &-6.2120D-02,  6.4780D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
     &-7.1090D-03,  1.3350D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
      DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
     &4.0000D-01,  6.2800D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
     &-5.9090D-02,  6.4360D-01,  0.0000D+00,  0.0000D+00,  0.0000D+00,
     &-6.5240D-03,  1.4510D-02,  0.0000D+00,  0.0000D+00,  0.0000D+00/
C...Expansion coefficients for gluon distribution.
      DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
     &8.8800D-01,  0.0000D+00,  3.1100D+00,  6.0000D+00,  0.0000D+00,
     &-1.8020D+00, -1.5760D+00, -1.3170D-01,  2.8010D+00, -1.7280D+01,
     &1.8120D+00,  1.2000D+00,  5.0680D-01, -1.2160D+01,  2.0490D+01/
      DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
     &7.9400D-01,  0.0000D+00,  2.8900D+00,  6.0000D+00,  0.0000D+00,
     &-9.1440D-01, -1.2370D+00,  5.9660D-01, -3.6710D+00, -8.1910D+00,
     &5.9660D-01,  6.5820D-01, -2.5500D-01, -2.3040D+00,  7.7580D+00/
C...Expansion coefficients for (up+down+strange) quark sea distribution.
      DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
     &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
     &-2.4280D-01, -2.1200D-01,  8.6730D-01,  1.2660D+00,  2.3820D+00,
     &1.3860D-01,  3.6710D-03,  4.7470D-02, -2.2150D+00,  3.4820D-01/
      DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
     &9.0000D-01,  0.0000D+00,  5.0000D+00,  0.0000D+00,  0.0000D+00,
     &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00,  5.6210D-01,
     &-1.7400D-01, -9.6230D-02,  1.5750D+00,  1.3780D+00, -2.7010D-01/
C...Expansion coefficients for charm quark sea distribution.
      DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
     &0.0000D+00, -2.2120D-02,  2.8940D+00,  0.0000D+00,  0.0000D+00,
     &7.9280D-02, -3.7850D-01,  9.4330D+00,  5.2480D+00,  8.3880D+00,
     &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
      DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
     &0.0000D+00, -8.8200D-02,  1.9240D+00,  0.0000D+00,  0.0000D+00,
     &6.2290D-02, -2.8920D-01,  2.4240D-01, -4.4630D+00, -8.3670D-01,
     &-4.0990D-02, -1.0820D-01,  2.0360D+00,  5.2090D+00, -4.8400D-02/
 
C...Euler's beta function, requires ordinary Gamma function
      EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
 
C...Reset output array.
      DO 100 KFL=-6,6
        XPPI(KFL)=0D0
  100 CONTINUE
 
      IF(MSTP(53).LE.2) THEN
C...Pion parton distributions from Owens.
C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
 
C...Determine set, Lambda and s expansion variable.
        NSET=MSTP(53)
        IF(NSET.EQ.1) ALAM=0.2D0
        IF(NSET.EQ.2) ALAM=0.4D0
        VINT(231)=4D0
        IF(MSTP(57).LE.0) THEN
          SD=0D0
        ELSE
          Q2IN=MIN(2D3,MAX(4D0,Q2))
          SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
        ENDIF
 
C...Calculate parton distributions.
        DO 120 KFL=1,4
          DO 110 IS=1,5
            TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
     &      COW(3,IS,KFL,NSET)*SD**2
  110     CONTINUE
          IF(KFL.EQ.1) THEN
            XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
          ELSE
            XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
     &      TS(5)*X**2)
          ENDIF
  120   CONTINUE
 
C...Put into output array.
        XPPI(0)=XQ(2)
        XPPI(1)=XQ(3)/6D0
        XPPI(2)=XQ(1)+XQ(3)/6D0
        XPPI(3)=XQ(3)/6D0
        XPPI(4)=XQ(4)
        XPPI(-1)=XQ(1)+XQ(3)/6D0
        XPPI(-2)=XQ(3)/6D0
        XPPI(-3)=XQ(3)/6D0
        XPPI(-4)=XQ(4)
 
C...Leading order pion parton distributions from 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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Arrays and data.
      DIMENSION XPPR(-6:6),Q2MIN(16)
      DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
     &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
 
C...Reset output array.
      DO 100 KFL=-6,6
        XPPR(KFL)=0D0
  100 CONTINUE
 
C...Common preliminaries.
      NSET=MAX(1,MIN(16,MSTP(51)))
      IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
      VINT(231)=Q2MIN(NSET)
      IF(MSTP(57).EQ.0) THEN
        Q2L=Q2MIN(NSET)
      ELSE
        Q2L=MAX(Q2MIN(NSET),Q2)
      ENDIF
 
      IF(NSET.GE.1.AND.NSET.LE.3) THEN
C...Interface to the CTEQ 3 parton distributions.
        QRT=SQRT(MAX(1D0,Q2L))
 
C...Loop over flavours.
        DO 110 I=-6,6
          IF(I.LE.0) THEN
            XPPR(I)=PYCTEQ(NSET,I,X,QRT)
          ELSEIF(I.LE.2) THEN
            XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
          ELSE
            XPPR(I)=XPPR(-I)
          ENDIF
  110   CONTINUE
 
      ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
C...Interface to the GRV 94 distributions.
        IF(NSET.EQ.4) THEN
          CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
        ELSEIF(NSET.EQ.5) THEN
          CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
        ELSE
          CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
        ENDIF
 
C...Put into output array.
        XPPR(0)=GL
        XPPR(-1)=0.5D0*(UDB+DEL)
        XPPR(-2)=0.5D0*(UDB-DEL)
        XPPR(-3)=SB
        XPPR(-4)=CHM
        XPPR(-5)=BOT
        XPPR(1)=DV+XPPR(-1)
        XPPR(2)=UV+XPPR(-2)
        XPPR(3)=SB
        XPPR(4)=CHM
        XPPR(5)=BOT
 
      ELSEIF(NSET.EQ.7) THEN
C...Interface to the CTEQ 5L parton distributions.
C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
C...freezing x*f(x,Q2) at borders. 
        QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
        XIN=MAX(1D-6,MIN(1D0,X))
 
C...Loop over flavours (with u <-> d notation mismatch).
        SUMUDB=PYCT5L(-1,XIN,QRT)
        RATUDB=PYCT5L(-2,XIN,QRT)
        DO 120 I=-5,2
          IF(I.EQ.1) THEN
            XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
          ELSEIF(I.EQ.2) THEN
            XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
          ELSEIF(I.EQ.-1) THEN
            XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
          ELSEIF(I.EQ.-2) THEN
            XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
          ELSE
            XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
            IF(I.LT.0) XPPR(-I)=XPPR(I)
          ENDIF
  120   CONTINUE
 
      ELSEIF(NSET.EQ.8) THEN
C...Interface to the CTEQ 5M1 parton distributions.
        QRT=SQRT(MAX(1D0,MIN(1D4,Q2L)))
        XIN=MAX(1D-6,MIN(1D0,X))
 
C...Loop over flavours (with u <-> d notation mismatch).
        SUMUDB=PYCT5M(-1,XIN,QRT)
        RATUDB=PYCT5M(-2,XIN,QRT)
        DO 130 I=-5,2
          IF(I.EQ.1) THEN
            XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
          ELSEIF(I.EQ.2) THEN
            XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
          ELSEIF(I.EQ.-1) THEN
            XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
          ELSEIF(I.EQ.-2) THEN
            XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
          ELSE
            XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
            IF(I.LT.0) XPPR(-I)=XPPR(I)
          ENDIF
  130   CONTINUE
 
      ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
C...obsolete but offers backwards compatibility. 
        CALL PYPDPO(X,Q2L,XPPR) 
 
C...Symmetric choice for debugging only
      ELSEIF(NSET.EQ.16) THEN
        XPPR(0)=.5D0/X
        XPPR(1)=.05D0/X
        XPPR(2)=.05D0/X
        XPPR(3)=.05D0/X
        XPPR(4)=.05D0/X
        XPPR(5)=.05D0/X
        XPPR(-1)=.05D0/X
        XPPR(-2)=.05D0/X
        XPPR(-3)=.05D0/X
        XPPR(-4)=.05D0/X
        XPPR(-5)=.05D0/X
 
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYCTEQ
C...Gives the CTEQ 3 parton distribution function sets in
C...parametrized form, of October 24, 1994.
C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
C...J. Qiu, W.K. Tung and H. Weerts.
 
      FUNCTION PYCTEQ (ISET, IPRT, X, Q)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...Data on Lambda values of fits, minimum Q and quark masses.
      DIMENSION ALM(3), QMS(4:6)
      DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
      DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
 
C....Check flavour thresholds. Set up QI for SB.
      IP = IABS(IPRT)
      IF(IP .GE. 4) THEN
        IF(Q .LE. QMS(IP)) THEN
          PYCTEQ = 0D0
          RETURN
        ENDIF
        QI = QMS(IP)
      ELSE
        QI = QMN
      ENDIF
 
C...Use "standard lambda" of parametrization program for expansion.
      ALAM = ALM (ISET)
      SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
      SB = LOG (SBL)
      SB2 = SB*SB
      SB3 = SB2*SB
 
C...Expansion for CTEQ3L.
      IF(ISET .EQ. 1) THEN
        IF(IPRT .EQ. 2) THEN
          A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
     &    0.3171D+00*SB3)
          A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
          A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
          A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
          A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
          A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
        ELSEIF(IPRT .EQ. 1) THEN
          A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
     &    0.7728D+00*SB3)
          A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
          A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
          A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
          A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
          A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
        ELSEIF(IPRT .EQ. 0) THEN
          A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
     &    0.5343D+00*SB3)
          A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
          A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
          A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
          A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
          A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
        ELSEIF(IPRT .EQ. -1) THEN
          A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
     &    0.2031D+01*SB3)
          A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
          A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
          A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
          A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
          A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
        ELSEIF(IPRT .EQ. -2) THEN
          A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
     &    0.9872D-01*SB3)
          A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
          A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
          A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
          A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
          A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
        ELSEIF(IPRT .EQ. -3) THEN
          A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
     &    0.8390D+00*SB3)
          A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
          A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
          A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
          A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
          A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
        ELSEIF(IPRT .EQ. -4) THEN
          A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
     &    0.1651D-01*SB2)
          A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
          A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
          A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
          A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
          A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
        ELSEIF(IPRT .EQ. -5) THEN
          A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
     &    0.3702D+01*SB2)
          A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
          A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
          A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
          A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
          A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
        ELSEIF(IPRT .EQ. -6) THEN
          A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
     &    0.6943D+00*SB2)
          A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
          A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
          A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
          A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
          A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
        ENDIF
 
C...Expansion for CTEQ3M.
      ELSEIF(ISET .EQ. 2) THEN
        IF(IPRT .EQ. 2) THEN
          A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
     &    0.2935D+00*SB3)
          A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
          A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
          A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
          A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
          A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
        ELSEIF(IPRT .EQ. 1) THEN
          A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
     &    0.4305D-01*SB3)
          A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
          A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
          A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
          A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
          A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
        ELSEIF(IPRT .EQ. 0) THEN
          A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
     &    0.1037D-01*SB3)
          A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
          A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
          A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
          A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
          A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
        ELSEIF(IPRT .EQ. -1) THEN
          A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
     &    0.1602D+01*SB3)
          A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
          A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
          A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
          A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
          A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
        ELSEIF(IPRT .EQ. -2) THEN
          A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
     &    0.2496D+00*SB3)
          A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
          A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
          A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
          A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
          A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
        ELSEIF(IPRT .EQ. -3) THEN
          A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
     &    0.1936D+01*SB3)
          A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
          A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
          A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
          A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
          A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
        ELSEIF(IPRT .EQ. -4) THEN
          A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
     &    0.5348D+00*SB2)
          A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
          A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
          A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
          A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
          A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
        ELSEIF(IPRT .EQ. -5) THEN
          A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
     &    0.1569D+01*SB2)
          A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
          A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
          A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
          A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
          A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
        ELSEIF(IPRT .EQ. -6) THEN
          A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
     &    0.8838D+01*SB2)
          A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
          A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
          A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
          A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
          A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
        ENDIF
 
C...Expansion for CTEQ3D.
      ELSEIF(ISET .EQ. 3) THEN
        IF(IPRT .EQ. 2) THEN
          A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
     &    0.2902D+00*SB3)
          A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
          A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
          A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
          A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
          A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
        ELSEIF(IPRT .EQ. 1) THEN
          A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
     &    0.7257D+00*SB3)
          A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
          A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
          A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
          A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
          A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
        ELSEIF(IPRT .EQ. 0) THEN
          A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
     &    0.2734D-04*SB3)
          A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
          A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
          A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
          A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
          A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
        ELSEIF(IPRT .EQ. -1) THEN
          A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
     &    0.1671D+01*SB3)
          A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
          A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
          A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
          A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
          A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
        ELSEIF(IPRT .EQ. -2) THEN
          A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
     &    0.2223D+00*SB3)
          A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
          A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
          A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
          A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
          A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
        ELSEIF(IPRT .EQ. -3) THEN
          A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
     &    0.1937D+01*SB3)
          A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
          A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
          A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
          A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
          A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
        ELSEIF(IPRT .EQ. -4) THEN
          A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
     &    0.5137D+00*SB2)
          A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
          A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
          A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
          A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
          A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
        ELSEIF(IPRT .EQ. -5) THEN
          A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
     &    0.2143D+01*SB2)
          A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
          A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
          A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
          A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
          A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
        ELSEIF(IPRT .EQ. -6) THEN
          A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
     &    0.9998D+01*SB2)
          A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
          A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
          A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
          A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
          A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
        ENDIF
      ENDIF
 
C...Calculation of x * f(x, Q).
      PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
     &   *(LOG(1D0+1D0/X))**A5 )
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGRVL
C...Gives the GRV 94 L (leading order) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Common expressions.
      MU2  = 0.23D0
      LAM2 = 0.2322D0 * 0.2322D0
      S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
      DS = SQRT (S)
      S2 = S * S
      S3 = S2 * S
 
C...uv :
      NU  =  2.284D0 + 0.802D0 * S + 0.055D0 * S2
      AKU =  0.590D0 - 0.024D0 * S
      BKU =  0.131D0 + 0.063D0 * S
      AU  = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
      BU  =  0.213D0 + 2.669D0 * S - 0.728D0 * S2
      CU  =  8.854D0 - 9.135D0 * S + 1.979D0 * S2
      DU  =  2.997D0 + 0.753D0 * S - 0.076D0 * S2
      UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
 
C...dv :
      ND  =  0.371D0 + 0.083D0 * S + 0.039D0 * S2
      AKD =  0.376D0
      BKD =  0.486D0 + 0.062D0 * S
      AD  = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
      BD  =  12.41D0 - 10.52D0 * S + 2.267D0 * S2
      CD  =  6.373D0 - 6.208D0 * S + 1.418D0 * S2
      DD  =  3.691D0 + 0.799D0 * S - 0.071D0 * S2
      DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
 
C...del :
      NE  =  0.082D0 + 0.014D0 * S + 0.008D0 * S2
      AKE =  0.409D0 - 0.005D0 * S
      BKE =  0.799D0 + 0.071D0 * S
      AE  = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
      BE  =  90.31D0 - 74.15D0 * S + 7.645D0 * S2
      CE  =  0.0D0
      DE  =  7.486D0 + 1.217D0 * S - 0.159D0 * S2
      DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
 
C...udb :
      ALX =  1.451D0
      BEX =  0.271D0
      AKX =  0.410D0 - 0.232D0 * S
      BKX =  0.534D0 - 0.457D0 * S
      AGX =  0.890D0 - 0.140D0 * S
      BGX = -0.981D0
      CX  =  0.320D0 + 0.683D0 * S
      DX  =  4.752D0 + 1.164D0 * S + 0.286D0 * S2
      EX  =  4.119D0 + 1.713D0 * S
      ESX =  0.682D0 + 2.978D0 * S
      UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
     & DX, EX, ESX)
 
C...sb :
      STS =  0D0
      ALS =  0.914D0
      BES =  0.577D0
      AKS =  1.798D0 - 0.596D0 * S
      AS  = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
      BS  =  18.92D0 - 16.73D0 * DS + 5.168D0 * S
      DST =  6.379D0 - 0.350D0 * S  + 0.142D0 * S2
      EST =  3.981D0 + 1.638D0 * S
      ESS =  6.402D0
      SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
 
C...cb :
      STC =  0.888D0
      ALC =  1.01D0
      BEC =  0.37D0
      AKC =  0D0
      AC  =  0D0
      BC  =  4.24D0  - 0.804D0 * S
      DCT =  3.46D0  - 1.076D0 * S
      ECT =  4.61D0  + 1.49D0  * S
      ESC =  2.555D0 + 1.961D0 * S
      CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
 
C...bb :
      STB =  1.351D0
      ALB =  1.00D0
      BEB =  0.51D0
      AKB =  0D0
      AB  =  0D0
      BB  =  1.848D0
      DBT =  2.929D0 + 1.396D0 * S
      EBT =  4.71D0  + 1.514D0 * S
      ESB =  4.02D0  + 1.239D0 * S
      BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
 
C...gl :
      ALG =  0.524D0
      BEG =  1.088D0
      AKG =  1.742D0 - 0.930D0 * S
      BKG =                         - 0.399D0 * S2
      AG  =  7.486D0 - 2.185D0 * S
      BG  =  16.69D0 - 22.74D0 * S  + 5.779D0 * S2
      CG  = -25.59D0 + 29.71D0 * S  - 7.296D0 * S2
      DG  =  2.792D0 + 2.215D0 * S  + 0.422D0 * S2 - 0.104D0 * S3
      EG  =  0.807D0 + 2.005D0 * S
      ESG =  3.841D0 + 0.316D0 * S
      GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
     & DG, EG, ESG)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGRVM
C...Gives the GRV 94 M (MSbar) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Common expressions.
      MU2  = 0.34D0
      LAM2 = 0.248D0 * 0.248D0
      S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
      DS = SQRT (S)
      S2 = S * S
      S3 = S2 * S
 
C...uv :
      NU  =  1.304D0 + 0.863D0 * S
      AKU =  0.558D0 - 0.020D0 * S
      BKU =          0.183D0 * S
      AU  = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
      BU  =  6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
      CU  =  7.771D0 - 10.09D0 * S + 2.630D0 * S2
      DU  =  3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
      UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
 
C...dv :
      ND  =  0.102D0 - 0.017D0 * S + 0.005D0 * S2
      AKD =  0.270D0 - 0.019D0 * S
      BKD =  0.260D0
      AD  =  2.393D0 + 6.228D0 * S - 0.881D0 * S2
      BD  =  46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
      CD  =  17.83D0 - 53.47D0 * S + 21.24D0 * S2
      DD  =  4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
      DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
 
C...del :
      NE  =  0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
      AKE =  0.409D0 - 0.007D0 * S
      BKE =  0.782D0 + 0.082D0 * S
      AE  = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
      BE  =  90.20D0 - 74.97D0 * S + 4.526D0 * S2
      CE  =  0.0D0
      DE  =  8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
      DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
 
C...udb :
      ALX =  0.877D0
      BEX =  0.561D0
      AKX =  0.275D0
      BKX =  0.0D0
      AGX =  0.997D0
      BGX =  3.210D0 - 1.866D0 * S
      CX  =  7.300D0
      DX  =  9.010D0 + 0.896D0 * DS + 0.222D0 * S2
      EX  =  3.077D0 + 1.446D0 * S
      ESX =  3.173D0 - 2.445D0 * DS + 2.207D0 * S
      UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
     & DX, EX, ESX)
 
C...sb :
      STS =  0D0
      ALS =  0.756D0
      BES =  0.216D0
      AKS =  1.690D0 + 0.650D0 * DS - 0.922D0 * S
      AS  = -4.329D0 + 1.131D0 * S
      BS  =  9.568D0 - 1.744D0 * S
      DST =  9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
      EST =  3.031D0 + 1.639D0 * S
      ESS =  5.837D0 + 0.815D0 * S
      SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
 
C...cb :
      STC =  0.820D0
      ALC =  0.98D0
      BEC =  0D0
      AKC = -0.625D0 - 0.523D0 * S
      AC  =  0D0
      BC  =  1.896D0 + 1.616D0 * S
      DCT =  4.12D0  + 0.683D0 * S
      ECT =  4.36D0  + 1.328D0 * S
      ESC =  0.677D0 + 0.679D0 * S
      CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
 
C...bb :
      STB =  1.297D0
      ALB =  0.99D0
      BEB =  0D0
      AKB =          - 0.193D0 * S
      AB  =  0D0
      BB  =  0D0
      DBT =  3.447D0 + 0.927D0 * S
      EBT =  4.68D0  + 1.259D0 * S
      ESB =  1.892D0 + 2.199D0 * S
      BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
 
C...gl :
       ALG =  1.014D0
       BEG =  1.738D0
       AKG =  1.724D0 + 0.157D0 * S
       BKG =  0.800D0 + 1.016D0 * S
       AG  =  7.517D0 - 2.547D0 * S
       BG  =  34.09D0 - 52.21D0 * DS + 17.47D0 * S
       CG  =  4.039D0 + 1.491D0 * S
       DG  =  3.404D0 + 0.830D0 * S
       EG  = -1.112D0 + 3.438D0 * S  - 0.302D0 * S2
       ESG =  3.256D0 - 0.436D0 * S
       GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
 
       RETURN
       END
 
C*********************************************************************
 
C...PYGRVD
C...Gives the GRV 94 D (DIS) parton distribution function set
C...in parametrized form.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Common expressions.
      MU2  = 0.34D0
      LAM2 = 0.248D0 * 0.248D0
      S  = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
      DS = SQRT (S)
      S2 = S * S
      S3 = S2 * S
 
C...uv :
      NU  =  2.484D0 + 0.116D0 * S + 0.093D0 * S2
      AKU =  0.563D0 - 0.025D0 * S
      BKU =  0.054D0 + 0.154D0 * S
      AU  = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
      BU  = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
      CU  =  11.52D0 - 12.99D0 * S + 3.161D0 * S2
      DU  =  2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
      UV  = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
 
C...dv :
      ND  =  0.156D0 - 0.017D0 * S
      AKD =  0.299D0 - 0.022D0 * S
      BKD =  0.259D0 - 0.015D0 * S
      AD  =  3.445D0 + 1.278D0 * S + 0.326D0 * S2
      BD  = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
      CD  =  55.45D0 - 69.92D0 * S + 20.78D0 * S2
      DD  =  3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
      DV  = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
 
C...del :
      NE  =  0.099D0 + 0.019D0 * S + 0.002D0 * S2
      AKE =  0.419D0 - 0.013D0 * S
      BKE =  1.064D0 - 0.038D0 * S
      AE  = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
      BE  =  28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
      CE  =  84.57D0 - 108.8D0 * S + 31.52D0 * S2
      DE  =  7.469D0 + 2.480D0 * S - 0.866D0 * S2
      DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
 
C...udb :
      ALX =  1.215D0
      BEX =  0.466D0
      AKX =  0.326D0 + 0.150D0 * S
      BKX =  0.956D0 + 0.405D0 * S
      AGX =  0.272D0
      BGX =  3.794D0 - 2.359D0 * DS
      CX  =  2.014D0
      DX  =  7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
      EX  =  3.049D0 + 1.597D0 * S
      ESX =  4.396D0 - 4.594D0 * DS + 3.268D0 * S
      UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
     & DX, EX, ESX)
 
C...sb :
      STS =  0D0
      ALS =  0.175D0
      BES =  0.344D0
      AKS =  1.415D0 - 0.641D0 * DS
      AS  =  0.580D0 - 9.763D0 * DS + 6.795D0 * S  - 0.558D0 * S2
      BS  =  5.617D0 + 5.709D0 * DS - 3.972D0 * S
      DST =  13.78D0 - 9.581D0 * S  + 5.370D0 * S2 - 0.996D0 * S3
      EST =  4.546D0 + 0.372D0 * S2
      ESS =  5.053D0 - 1.070D0 * S  + 0.805D0 * S2
      SB  = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
 
C...cb :
      STC =  0.820D0
      ALC =  0.98D0
      BEC =  0D0
      AKC = -0.625D0 - 0.523D0 * S
      AC  =  0D0
      BC  =  1.896D0 + 1.616D0 * S
      DCT =  4.12D0  + 0.683D0 * S
      ECT =  4.36D0  + 1.328D0 * S
      ESC =  0.677D0 + 0.679D0 * S
      CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
 
C...bb :
      STB =  1.297D0
      ALB =  0.99D0
      BEB =  0D0
      AKB =          - 0.193D0 * S
      AB  =  0D0
      BB  =  0D0
      DBT =  3.447D0 + 0.927D0 * S
      EBT =  4.68D0  + 1.259D0 * S
      ESB =  1.892D0 + 2.199D0 * S
      BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
 
C...gl :
      ALG =  1.258D0
      BEG =  1.846D0
      AKG =  2.423D0
      BKG =  2.427D0 + 1.311D0 * S  - 0.153D0 * S2
      AG  =  25.09D0 - 7.935D0 * S
      BG  = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
      CG  =  590.3D0 - 173.8D0 * S
      DG  =  5.196D0 + 1.857D0 * S
      EG  = -1.648D0 + 3.988D0 * S  - 0.432D0 * S2
      ESG =  3.232D0 - 0.542D0 * S
      GL  = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGRVV
C...Auxiliary for the GRV 94 parton distribution functions
C...for u and d valence and d-u sea.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Evaluation.
      DX = SQRT (X)
      PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
     & (1D0- X)**D
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGRVW
C...Auxiliary for the GRV 94 parton distribution functions
C...for d+u sea and gluon.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Evaluation.
      LX = LOG (1D0/X)
      PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
     &     * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGRVS
C...Auxiliary for the GRV 94 parton distribution functions
C...for s, c and b sea.
C...Authors: M. Glueck, E. Reya and A. Vogt.
 
      FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION (A - Z)
 
C...Evaluation.
      IF(S.LE.STH) THEN
        PYGRVS = 0D0
      ELSE
        DX = SQRT (X)
        LX = LOG (1D0/X)
        PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
     &     (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
      ENDIF
 
      RETURN
      END

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

C...CTEQ5M1 and CTEQ5L Parton Distribution Functions 
C...in Parametrized Form
C...            September 15, 1999
C
C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
C...      CTEQ5 PPARTON DISTRIBUTIONS"
C...hep-ph/9903282

C...The CTEQ5M1 set given here is an updated version of the original 
C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
C...The differences between CTEQ5M and CTEQ5M1 are insignificant for 
C...almost all applications. 
C...The improvement is in the QCD evolution which is now more 
C...accurate, and which agrees completely with the benchmark work 
C...of the HERA 96/97 Workshop.
C...The differences between the parametrized and the corresponding 
C...table versions (on which it is based) are of similar order as 
C...between the two version.
    
C...!! Because accurate parametrizations over a wide range of (x,Q) 
C...is hard to obtain, only the most widely used sets CTEQ5M and 
C...CTEQ5L are available in parametrized form for now. 

C...These parametrizations were obtained by Jon Pumplin.

C  Iset   PDF        Description              Alpha_s(Mz)  Lam4  Lam5
C -------------------------------------------------------------------
C   1    CTEQ5M1  Standard NLO MSbar scheme      0.118     326   226
C   3    CTEQ5L   Leading Order                  0.127     192   146
C -------------------------------------------------------------------
C...Note the Qcd-lambda values given for CTEQ5L is for the leading 
C...order form of Alpha_s!!  Alpha_s(Mz) gives the absolute 
C...calibration.

C...The two Iset value are adopted to agree with the standard table 
C...versions.
       
C...Range of validity:  
C...The range of (x, Q) covered by this parametrization of the QCD 
C...evolved parton distributions is 1E-6 < x < 1 ; 
C...1.1 GeV < Q < 10 TeV.  Of course, the PDF's are constrained by 
C...data only in a subset of that region; and the assumed DGLAP 
C...evolution is unlikely to be valid for all of it either.

C...The range of (x, Q) used in the CTEQ5 round of global analysis is 
C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for 
C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and   
C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.

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

C...PYCT5L 
C...Auxiliary function for parametrization of CTEQ5L. 
C...Author: J. Pumplin 9/99.

      FUNCTION PYCT5L(IFL,X,Q)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

      PARAMETER (NEX=8, NLF=2)
      DIMENSION AM(0:NEX,0:NLF,-5:2)
      DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
      DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
      DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
      DIMENSION AF(0:NEX)

      DATA MEXVEC( 2) / 8 /
      DATA MLFVEC( 2) / 2 /
      DATA UT1VEC( 2) /  0.4971265E+01 /
      DATA UT2VEC( 2) / -0.1105128E+01 /
      DATA ALFVEC( 2) /  0.2987216E+00 /
      DATA QMAVEC( 2) /  0.0000000E+00 /
      DATA (AM( 0,K, 2),K=0, 2)
     & /  0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
      DATA (AM( 1,K, 2),K=0, 2)
     & /  0.9714424E+00,  0.1011827E-01, -0.1023660E-01 /
      DATA (AM( 2,K, 2),K=0, 2)
     & / -0.1651006E+02,  0.7959721E+01,  0.8810563E+01 /
      DATA (AM( 3,K, 2),K=0, 2)
     & / -0.1643394E+02,  0.5892854E+01,  0.9348874E+01 /
      DATA (AM( 4,K, 2),K=0, 2)
     & /  0.3067422E+02,  0.4235796E+01, -0.5112136E+00 /
      DATA (AM( 5,K, 2),K=0, 2)
     & /  0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
      DATA (AM( 6,K, 2),K=0, 2)
     & / -0.1095451E+02,  0.3006577E+01,  0.5638136E+01 /
      DATA (AM( 7,K, 2),K=0, 2)
     & / -0.1172251E+02, -0.2183624E+01,  0.4955794E+01 /
      DATA (AM( 8,K, 2),K=0, 2)
     & /  0.1662533E-01,  0.7622870E-02, -0.4895887E-03 /

      DATA MEXVEC( 1) / 8 /
      DATA MLFVEC( 1) / 2 /
      DATA UT1VEC( 1) /  0.2612618E+01 /
      DATA UT2VEC( 1) / -0.1258304E+06 /
      DATA ALFVEC( 1) /  0.3407552E+00 /
      DATA QMAVEC( 1) /  0.0000000E+00 /
      DATA (AM( 0,K, 1),K=0, 2)
     & /  0.9905300E+00, -0.4502235E+00,  0.1624441E+00 /
      DATA (AM( 1,K, 1),K=0, 2)
     & /  0.8867534E+00,  0.1630829E-01, -0.4049085E-01 /
      DATA (AM( 2,K, 1),K=0, 2)
     & /  0.8547974E+00,  0.3336301E+00,  0.1371388E+00 /
      DATA (AM( 3,K, 1),K=0, 2)
     & /  0.2941113E+00, -0.1527905E+01,  0.2331879E+00 /
      DATA (AM( 4,K, 1),K=0, 2)
     & /  0.3384235E+02,  0.3715315E+01,  0.8276930E+00 /
      DATA (AM( 5,K, 1),K=0, 2)
     & /  0.6230115E+01,  0.3134639E+01, -0.1729099E+01 /
      DATA (AM( 6,K, 1),K=0, 2)
     & / -0.1186928E+01, -0.3282460E+00,  0.1052020E+00 /
      DATA (AM( 7,K, 1),K=0, 2)
     & / -0.8545702E+01, -0.6247947E+01,  0.3692561E+01 /
      DATA (AM( 8,K, 1),K=0, 2)
     & /  0.1724598E-01,  0.7120465E-02,  0.4003646E-04 /

      DATA MEXVEC( 0) / 8 /
      DATA MLFVEC( 0) / 2 /
      DATA UT1VEC( 0) / -0.4656819E+00 /
      DATA UT2VEC( 0) / -0.2742390E+03 /
      DATA ALFVEC( 0) /  0.4491863E+00 /
      DATA QMAVEC( 0) /  0.0000000E+00 /
      DATA (AM( 0,K, 0),K=0, 2)
     & /  0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
      DATA (AM( 1,K, 0),K=0, 2)
     & / -0.9421449E+02,  0.3995885E+01,  0.1607363E+01 /
      DATA (AM( 2,K, 0),K=0, 2)
     & /  0.4206383E+01,  0.2485954E+00,  0.2497468E+00 /
      DATA (AM( 3,K, 0),K=0, 2)
     & /  0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
      DATA (AM( 4,K, 0),K=0, 2)
     & / -0.1013897E+03, -0.7113478E+00,  0.2621865E+00 /
      DATA (AM( 5,K, 0),K=0, 2)
     & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
      DATA (AM( 6,K, 0),K=0, 2)
     & /  0.1627137E+01,  0.4954111E+00, -0.6387009E+00 /
      DATA (AM( 7,K, 0),K=0, 2)
     & /  0.1537698E+00, -0.2487878E+00,  0.8305947E+00 /
      DATA (AM( 8,K, 0),K=0, 2)
     & /  0.2496448E-01,  0.2457823E-02,  0.8234276E-03 /

      DATA MEXVEC(-1) / 8 /
      DATA MLFVEC(-1) / 2 /
      DATA UT1VEC(-1) /  0.3862583E+01 /
      DATA UT2VEC(-1) / -0.1265969E+01 /
      DATA ALFVEC(-1) /  0.2457668E+00 /
      DATA QMAVEC(-1) /  0.0000000E+00 /
      DATA (AM( 0,K,-1),K=0, 2)
     & /  0.2647441E+02,  0.1059277E+02, -0.9176654E+00 /
      DATA (AM( 1,K,-1),K=0, 2)
     & /  0.1990636E+01,  0.8558918E-01,  0.4248667E-01 /
      DATA (AM( 2,K,-1),K=0, 2)
     & / -0.1476095E+02, -0.3276255E+02,  0.1558110E+01 /
      DATA (AM( 3,K,-1),K=0, 2)
     & / -0.2966889E+01, -0.3649037E+02,  0.1195914E+01 /
      DATA (AM( 4,K,-1),K=0, 2)
     & / -0.1000519E+03, -0.2464635E+01,  0.1964849E+00 /
      DATA (AM( 5,K,-1),K=0, 2)
     & /  0.3718331E+02,  0.4700389E+02, -0.2772142E+01 /
      DATA (AM( 6,K,-1),K=0, 2)
     & / -0.1872722E+02, -0.2291189E+02,  0.1089052E+01 /
      DATA (AM( 7,K,-1),K=0, 2)
     & / -0.1628146E+02, -0.1823993E+02,  0.2537369E+01 /
      DATA (AM( 8,K,-1),K=0, 2)
     & / -0.1156300E+01, -0.1280495E+00,  0.5153245E-01 /

      DATA MEXVEC(-2) / 7 /
      DATA MLFVEC(-2) / 2 /
      DATA UT1VEC(-2) /  0.1895615E+00 /
      DATA UT2VEC(-2) / -0.3069097E+01 /
      DATA ALFVEC(-2) /  0.5293999E+00 /
      DATA QMAVEC(-2) /  0.0000000E+00 /
      DATA (AM( 0,K,-2),K=0, 2)
     & / -0.6556775E+00,  0.2490190E+00,  0.3966485E-01 /
      DATA (AM( 1,K,-2),K=0, 2)
     & /  0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
      DATA (AM( 2,K,-2),K=0, 2)
     & / -0.2371436E+01,  0.3566814E+00, -0.2834683E+00 /
      DATA (AM( 3,K,-2),K=0, 2)
     & / -0.6152826E+01,  0.8339877E+00, -0.7233230E+00 /
      DATA (AM( 4,K,-2),K=0, 2)
     & / -0.8346558E+01,  0.2892168E+01,  0.2137099E+00 /
      DATA (AM( 5,K,-2),K=0, 2)
     & /  0.1279530E+02,  0.1021114E+00,  0.5787439E+00 /
      DATA (AM( 6,K,-2),K=0, 2)
     & /  0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
      DATA (AM( 7,K,-2),K=0, 2)
     & / -0.2795725E+02, -0.5263392E+00,  0.1290229E+01 /

      DATA MEXVEC(-3) / 7 /
      DATA MLFVEC(-3) / 2 /
      DATA UT1VEC(-3) /  0.3753257E+01 /
      DATA UT2VEC(-3) / -0.1113085E+01 /
      DATA ALFVEC(-3) /  0.3713141E+00 /
      DATA QMAVEC(-3) /  0.0000000E+00 /
      DATA (AM( 0,K,-3),K=0, 2)
     & /  0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
      DATA (AM( 1,K,-3),K=0, 2)
     & /  0.2702644E+01,  0.6763243E+00,  0.7231586E-02 /
      DATA (AM( 2,K,-3),K=0, 2)
     & / -0.1857924E+02,  0.3907500E+01,  0.5850109E+01 /
      DATA (AM( 3,K,-3),K=0, 2)
     & / -0.3044793E+02,  0.2639332E+01,  0.5566644E+01 /
      DATA (AM( 4,K,-3),K=0, 2)
     & / -0.4258011E+01, -0.5429244E+01,  0.4418946E+00 /
      DATA (AM( 5,K,-3),K=0, 2)
     & /  0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
      DATA (AM( 6,K,-3),K=0, 2)
     & / -0.1658858E+02,  0.2923275E+01,  0.2266286E+01 /
      DATA (AM( 7,K,-3),K=0, 2)
     & / -0.1149263E+02,  0.2877475E+01, -0.7999105E+00 /

      DATA MEXVEC(-4) / 7 /
      DATA MLFVEC(-4) / 2 /
      DATA UT1VEC(-4) /  0.4400772E+01 /
      DATA UT2VEC(-4) / -0.1356116E+01 /
      DATA ALFVEC(-4) /  0.3712017E-01 /
      DATA QMAVEC(-4) /  0.1300000E+01 /
      DATA (AM( 0,K,-4),K=0, 2)
     & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
      DATA (AM( 1,K,-4),K=0, 2)
     & /  0.2754618E+01,  0.8338636E+00, -0.6885160E-01 /
      DATA (AM( 2,K,-4),K=0, 2)
     & / -0.1657987E+02,  0.1439143E+02, -0.6887240E+00 /
      DATA (AM( 3,K,-4),K=0, 2)
     & / -0.2800703E+02,  0.1535966E+02, -0.7377693E+00 /
      DATA (AM( 4,K,-4),K=0, 2)
     & / -0.6460216E+01, -0.4783019E+01,  0.4913297E+00 /
      DATA (AM( 5,K,-4),K=0, 2)
     & /  0.3141830E+02, -0.3178031E+02,  0.7136013E+01 /
      DATA (AM( 6,K,-4),K=0, 2)
     & / -0.1802509E+02,  0.1862163E+02, -0.4632843E+01 /
      DATA (AM( 7,K,-4),K=0, 2)
     & / -0.1240412E+02,  0.2565386E+02, -0.1066570E+02 /

      DATA MEXVEC(-5) / 6 /
      DATA MLFVEC(-5) / 2 /
      DATA UT1VEC(-5) /  0.5562568E+01 /
      DATA UT2VEC(-5) / -0.1801317E+01 /
      DATA ALFVEC(-5) /  0.4952010E-02 /
      DATA QMAVEC(-5) /  0.4500000E+01 /
      DATA (AM( 0,K,-5),K=0, 2)
     & / -0.6031237E+01,  0.1992727E+01, -0.1076331E+01 /
      DATA (AM( 1,K,-5),K=0, 2)
     & /  0.2933912E+01,  0.5839674E+00,  0.7509435E-01 /
      DATA (AM( 2,K,-5),K=0, 2)
     & / -0.8284919E+01,  0.1488593E+01, -0.8251678E+00 /
      DATA (AM( 3,K,-5),K=0, 2)
     & / -0.1925986E+02,  0.2805753E+01, -0.3015446E+01 /
      DATA (AM( 4,K,-5),K=0, 2)
     & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
      DATA (AM( 5,K,-5),K=0, 2)
     & /  0.2193195E+02, -0.1788518E+02,  0.9460908E+01 /
      DATA (AM( 6,K,-5),K=0, 2)
     & / -0.1327377E+02,  0.1201754E+02, -0.6277844E+01 /

      IF(Q .LE. QMAVEC(IFL)) THEN
         PYCT5L = 0.D0
         RETURN
      ENDIF

      IF(X .GE. 1.D0) THEN
         PYCT5L = 0.D0
         RETURN
      ENDIF

      TMP = LOG(Q/ALFVEC(IFL))
      IF(TMP .LE. 0.D0) THEN
         PYCT5L = 0.D0
         RETURN
      ENDIF

      SB = LOG(TMP)
      SB1 = SB - 1.2D0
      SB2 = SB1*SB1

      DO 110 I = 0, NEX
         AF(I) = 0.D0
         SBX = 1.D0
         DO 100 K = 0, MLFVEC(IFL)
            AF(I) = AF(I) + SBX*AM(I,K,IFL)
            SBX = SB1*SBX
  100    CONTINUE
  110 CONTINUE      

      Y = -LOG(X)
      U = LOG(X/0.00001D0)

      PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
      PART2 = AF(0)*(1.D0 - X) + AF(3)*X 
      PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
      PART4 = UT1VEC(IFL)*LOG(1.D0-X) + 
     &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)

      PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)

C...Include threshold factor.
      PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)

      RETURN
      END
 
C*********************************************************************

C...PYCT5M 
C...Auxiliary function for parametrization of CTEQ5M1.
C...Author: J. Pumplin 9/99.

      FUNCTION PYCT5M(IFL,X,Q)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

      PARAMETER (NEX=8, NLF=2)
      DIMENSION AM(0:NEX,0:NLF,-5:2)
      DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
      DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
      DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
      DIMENSION AF(0:NEX)

      DATA MEXVEC( 2) / 8 /
      DATA MLFVEC( 2) / 2 /
      DATA UT1VEC( 2) /  0.5141718E+01 /
      DATA UT2VEC( 2) / -0.1346944E+01 /
      DATA ALFVEC( 2) /  0.5260555E+00 /
      DATA QMAVEC( 2) /  0.0000000E+00 /
      DATA (AM( 0,K, 2),K=0, 2)
     & /  0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
      DATA (AM( 1,K, 2),K=0, 2)
     & /  0.9839410E+00,  0.4168426E-01, -0.5018952E-01 /
      DATA (AM( 2,K, 2),K=0, 2)
     & / -0.1651961E+02,  0.9246261E+01,  0.5996400E+01 /
      DATA (AM( 3,K, 2),K=0, 2)
     & / -0.2077936E+02,  0.9786469E+01,  0.7656465E+01 /
      DATA (AM( 4,K, 2),K=0, 2)
     & /  0.3054926E+02,  0.1889536E+01,  0.1380541E+01 /
      DATA (AM( 5,K, 2),K=0, 2)
     & /  0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
      DATA (AM( 6,K, 2),K=0, 2)
     & / -0.1426778E+02,  0.6239537E+01,  0.5254819E+01 /
      DATA (AM( 7,K, 2),K=0, 2)
     & / -0.1909811E+02,  0.3695678E+01,  0.5495729E+01 /
      DATA (AM( 8,K, 2),K=0, 2)
     & /  0.1889751E-01,  0.5027193E-02,  0.6624896E-03 /

      DATA MEXVEC( 1) / 8 /
      DATA MLFVEC( 1) / 2 /
      DATA UT1VEC( 1) /  0.4138426E+01 /
      DATA UT2VEC( 1) / -0.3221374E+01 /
      DATA ALFVEC( 1) /  0.4960962E+00 /
      DATA QMAVEC( 1) /  0.0000000E+00 /
      DATA (AM( 0,K, 1),K=0, 2)
     & /  0.1332497E+01, -0.3703718E+00,  0.1288638E+00 /
      DATA (AM( 1,K, 1),K=0, 2)
     & /  0.7544687E+00,  0.3255075E-01, -0.4706680E-01 /
      DATA (AM( 2,K, 1),K=0, 2)
     & / -0.7638814E+00,  0.5008313E+00, -0.9237374E-01 /
      DATA (AM( 3,K, 1),K=0, 2)
     & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
      DATA (AM( 4,K, 1),K=0, 2)
     & /  0.3991610E+02,  0.1979881E+01,  0.1775814E+01 /
      DATA (AM( 5,K, 1),K=0, 2)
     & /  0.6201080E+01,  0.2046288E+01,  0.3804571E+00 /
      DATA (AM( 6,K, 1),K=0, 2)
     & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
      DATA (AM( 7,K, 1),K=0, 2)
     & / -0.8631305E+01, -0.3981200E+01,  0.6970153E+00 /
      DATA (AM( 8,K, 1),K=0, 2)
     & /  0.2371230E-01,  0.5372683E-02,  0.1118701E-02 /

      DATA MEXVEC( 0) / 8 /
      DATA MLFVEC( 0) / 2 /
      DATA UT1VEC( 0) / -0.1026789E+01 /
      DATA UT2VEC( 0) / -0.9051707E+01 /
      DATA ALFVEC( 0) /  0.9462977E+00 /
      DATA QMAVEC( 0) /  0.0000000E+00 /
      DATA (AM( 0,K, 0),K=0, 2)
     & /  0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
      DATA (AM( 1,K, 0),K=0, 2)
     & / -0.9449972E+02,  0.1074771E+01,  0.2056055E+01 /
      DATA (AM( 2,K, 0),K=0, 2)
     & /  0.3701064E+01, -0.1167947E-02,  0.1933573E+00 /
      DATA (AM( 3,K, 0),K=0, 2)
     & /  0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
      DATA (AM( 4,K, 0),K=0, 2)
     & / -0.1014453E+03, -0.5707427E+00,  0.4511242E-01 /
      DATA (AM( 5,K, 0),K=0, 2)
     & /  0.6365168E+01,  0.1275354E+01, -0.4964081E+00 /
      DATA (AM( 6,K, 0),K=0, 2)
     & / -0.3370693E+01, -0.1122020E+01,  0.5947751E-01 /
      DATA (AM( 7,K, 0),K=0, 2)
     & / -0.5327270E+01, -0.9293556E+00,  0.6629940E+00 /
      DATA (AM( 8,K, 0),K=0, 2)
     & /  0.2437513E-01,  0.1600939E-02,  0.6855336E-03 /

      DATA MEXVEC(-1) / 8 /
      DATA MLFVEC(-1) / 2 /
      DATA UT1VEC(-1) /  0.5243571E+01 /
      DATA UT2VEC(-1) / -0.2870513E+01 /
      DATA ALFVEC(-1) /  0.6701448E+00 /
      DATA QMAVEC(-1) /  0.0000000E+00 /
      DATA (AM( 0,K,-1),K=0, 2)
     & /  0.2428863E+02,  0.1907035E+01, -0.4606457E+00 /
      DATA (AM( 1,K,-1),K=0, 2)
     & /  0.2006810E+01, -0.1265915E+00,  0.7153556E-02 /
      DATA (AM( 2,K,-1),K=0, 2)
     & / -0.1884546E+02, -0.2339471E+01,  0.5740679E+01 /
      DATA (AM( 3,K,-1),K=0, 2)
     & / -0.2527892E+02, -0.2044124E+01,  0.1280470E+02 /
      DATA (AM( 4,K,-1),K=0, 2)
     & / -0.1013824E+03, -0.1594199E+01,  0.2216401E+00 /
      DATA (AM( 5,K,-1),K=0, 2)
     & /  0.8070930E+02,  0.1792072E+01, -0.2164364E+02 /
      DATA (AM( 6,K,-1),K=0, 2)
     & / -0.4641050E+02,  0.1977338E+00,  0.1273014E+02 /
      DATA (AM( 7,K,-1),K=0, 2)
     & / -0.3910568E+02,  0.1719632E+01,  0.1086525E+02 /
      DATA (AM( 8,K,-1),K=0, 2)
     & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /

      DATA MEXVEC(-2) / 7 /
      DATA MLFVEC(-2) / 2 /
      DATA UT1VEC(-2) /  0.4782210E+01 /
      DATA UT2VEC(-2) / -0.1976856E+02 /
      DATA ALFVEC(-2) /  0.7558374E+00 /
      DATA QMAVEC(-2) /  0.0000000E+00 /
      DATA (AM( 0,K,-2),K=0, 2)
     & / -0.6216935E+00,  0.2369963E+00, -0.7909949E-02 /
      DATA (AM( 1,K,-2),K=0, 2)
     & /  0.1245440E+01, -0.1031510E+00,  0.4916523E-02 /
      DATA (AM( 2,K,-2),K=0, 2)
     & / -0.7060824E+01, -0.3875283E-01,  0.1784981E+00 /
      DATA (AM( 3,K,-2),K=0, 2)
     & / -0.7430595E+01,  0.1964572E+00, -0.1284999E+00 /
      DATA (AM( 4,K,-2),K=0, 2)
     & / -0.6897810E+01,  0.2620543E+01,  0.8012553E-02 /
      DATA (AM( 5,K,-2),K=0, 2)
     & /  0.1507713E+02,  0.2340307E-01,  0.2482535E+01 /
      DATA (AM( 6,K,-2),K=0, 2)
     & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
      DATA (AM( 7,K,-2),K=0, 2)
     & / -0.2571932E+02,  0.2903941E+00, -0.2848206E+01 /

      DATA MEXVEC(-3) / 7 /
      DATA MLFVEC(-3) / 2 /
      DATA UT1VEC(-3) /  0.4518239E+01 /
      DATA UT2VEC(-3) / -0.2690590E+01 /
      DATA ALFVEC(-3) /  0.6124079E+00 /
      DATA QMAVEC(-3) /  0.0000000E+00 /
      DATA (AM( 0,K,-3),K=0, 2)
     & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
      DATA (AM( 1,K,-3),K=0, 2)
     & /  0.2927174E+01,  0.4822709E+00, -0.1088787E-01 /
      DATA (AM( 2,K,-3),K=0, 2)
     & / -0.1771017E+02, -0.1416635E+01,  0.8467622E+01 /
      DATA (AM( 3,K,-3),K=0, 2)
     & / -0.4972782E+02, -0.3348547E+01,  0.1767061E+02 /
      DATA (AM( 4,K,-3),K=0, 2)
     & / -0.7102770E+01, -0.3205337E+01,  0.4101704E+00 /
      DATA (AM( 5,K,-3),K=0, 2)
     & /  0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
      DATA (AM( 6,K,-3),K=0, 2)
     & / -0.4090347E+02,  0.2103486E+01,  0.1416507E+02 /
      DATA (AM( 7,K,-3),K=0, 2)
     & / -0.2952639E+02,  0.5376136E+01,  0.7825585E+01 /

      DATA MEXVEC(-4) / 7 /
      DATA MLFVEC(-4) / 2 /
      DATA UT1VEC(-4) /  0.2783230E+01 /
      DATA UT2VEC(-4) / -0.1746328E+01 /
      DATA ALFVEC(-4) /  0.1115653E+01 /
      DATA QMAVEC(-4) /  0.1300000E+01 /
      DATA (AM( 0,K,-4),K=0, 2)
     & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
      DATA (AM( 1,K,-4),K=0, 2)
     & /  0.3345755E+01,  0.3187765E+00,  0.1378124E+00 /
      DATA (AM( 2,K,-4),K=0, 2)
     & / -0.2037615E+02,  0.4121687E+01,  0.2236520E+00 /
      DATA (AM( 3,K,-4),K=0, 2)
     & / -0.4703104E+02,  0.5353087E+01, -0.1455347E+01 /
      DATA (AM( 4,K,-4),K=0, 2)
     & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
      DATA (AM( 5,K,-4),K=0, 2)
     & /  0.5088892E+02, -0.8197304E+01,  0.8083451E+01 /
      DATA (AM( 6,K,-4),K=0, 2)
     & / -0.2819070E+02,  0.4554086E+01, -0.5890995E+01 /
      DATA (AM( 7,K,-4),K=0, 2)
     & / -0.1098238E+02,  0.2590096E+01, -0.8062879E+01 /

      DATA MEXVEC(-5) / 6 /
      DATA MLFVEC(-5) / 2 /
      DATA UT1VEC(-5) /  0.1619654E+02 /
      DATA UT2VEC(-5) / -0.3367346E+01 /
      DATA ALFVEC(-5) /  0.5109891E-02 /
      DATA QMAVEC(-5) /  0.4500000E+01 /
      DATA (AM( 0,K,-5),K=0, 2)
     & / -0.6800138E+01,  0.2493627E+01, -0.1075724E+01 /
      DATA (AM( 1,K,-5),K=0, 2)
     & /  0.3036555E+01,  0.3324733E+00,  0.2008298E+00 /
      DATA (AM( 2,K,-5),K=0, 2)
     & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
      DATA (AM( 3,K,-5),K=0, 2)
     & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
      DATA (AM( 4,K,-5),K=0, 2)
     & / -0.1099444E+02,  0.1320930E+01, -0.2353831E+01 /
      DATA (AM( 5,K,-5),K=0, 2)
     & /  0.1699299E+02, -0.3565802E+02,  0.3566872E+02 /
      DATA (AM( 6,K,-5),K=0, 2)
     & / -0.1465793E+02,  0.2703365E+02, -0.2176372E+02 /

      IF(Q .LE. QMAVEC(IFL)) THEN
         PYCT5M = 0.D0
         RETURN
      ENDIF

      IF(X .GE. 1.D0) THEN
         PYCT5M = 0.D0
         RETURN
      ENDIF

      TMP = LOG(Q/ALFVEC(IFL))
      IF(TMP .LE. 0.D0) THEN
         PYCT5M = 0.D0
         RETURN
      ENDIF

      SB = LOG(TMP)
      SB1 = SB - 1.2D0
      SB2 = SB1*SB1

      DO 110 I = 0, NEX
         AF(I) = 0.D0
         SBX = 1.D0
         DO 100 K = 0, MLFVEC(IFL)
            AF(I) = AF(I) + SBX*AM(I,K,IFL)
            SBX = SB1*SBX
  100    CONTINUE
  110 CONTINUE      

      Y = -LOG(X)
      U = LOG(X/0.00001D0)

      PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
      PART2 = AF(0)*(1.D0 - X) + AF(3)*X 
      PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
      PART4 = UT1VEC(IFL)*LOG(1.D0-X) + 
     &        AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)

      PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)

C...Include threshold factor.
      PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)

      RETURN
      END
 
C*********************************************************************
 
C...PYPDPO
C...Auxiliary to PYPDPR. Gives proton parton distributions according to 
C...a few older parametrizations, now obsolete but convenient for 
C...backwards checks.

      SUBROUTINE PYPDPO(X,Q2,XPPR)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
      DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
     &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
 
 
C...The following data lines are coefficients needed in the
C...Eichten, Hinchliffe, Lane, Quigg proton structure function
C...parametrizations, see below.
C...Powers of 1-x in different cases.
      DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
C...Expansion coefficients for up valence quark distribution.
      DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
     1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
     2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
     3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
     4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
     5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
     6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
     1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
     2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
     3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
     4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
     5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
     6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
     1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
     2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
     3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
     4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
     5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
     6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
     1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
     2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
     3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
     4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
     5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
     6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
C...Expansion coefficients for down valence quark distribution.
      DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
     1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
     2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
     3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
     4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
     5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
     6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
     1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
     2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
     3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
     4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
     5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
     6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
     1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
     2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
     3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
     4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
     5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
     6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
     1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
     2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
     3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
     4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
     5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
     6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
C...Expansion coefficients for up and down sea quark distributions.
      DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
     1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
     2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
     3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
     4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
     5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
     6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
     1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
     2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
     3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
     4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
     5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
     6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
     1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
     2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
     3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
     4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
     5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
     6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
     1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
     2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
     3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
     4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
     5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
     6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
C...Expansion coefficients for gluon distribution.
      DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
     2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
     3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
     4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
     5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
     6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
     1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
     2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
     3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
     4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
     5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
     6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
      DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
     1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
     2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
     3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
     4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
     5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
     6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
     1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
     2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
     3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
     4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
     5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
     6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
C...Expansion coefficients for strange sea quark distribution.
      DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
     1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
     2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
     3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
     4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
     5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
     6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
     1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
     2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
     3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
     4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
     5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
     6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
      DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
     1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
     2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
     3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
     4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
     5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
     6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
     1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
     2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
     3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
     4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
     5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
     6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
C...Expansion coefficients for charm sea quark distribution.
      DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
     2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
     3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
     4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
     5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
     6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
     1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
     2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
     3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
     4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
     5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
     6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
     1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
     2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
     3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
     4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
     5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
     6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
     1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
     2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
     3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
     4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
     5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
     6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
C...Expansion coefficients for bottom sea quark distribution.
      DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
     1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
     2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
     3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
     4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
     5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
     6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
     1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
     2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
     3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
     4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
     5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
     6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
     1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
     2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
     3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
     4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
     5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
     6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
     1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
     2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
     3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
     4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
     5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
     6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
C...Expansion coefficients for top sea quark distribution.
      DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
     1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
     2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
     3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
     4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
     5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
     6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
     1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
     2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
     3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
     4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
     5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
     6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
      DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
     1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
     2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
     3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
     4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
     5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
     6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
     1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
     2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
     3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
     4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
     5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
     6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
 
C...The following data lines are coefficients needed in the
C...Duke, Owens proton structure function parametrizations, see below.
C...Expansion coefficients for (up+down) valence quark distribution.
      DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
     1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
      DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
     1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
C...Expansion coefficients for down valence quark distribution.
      DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
     1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
     3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
      DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
     1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
     3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
C...Expansion coefficients for (up+down+strange) sea quark distribution.
      DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
     1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
     3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
      DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
     1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
     3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
C...Expansion coefficients for charm sea quark distribution.
      DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
     1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
     3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
       DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
     1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
     2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
     3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
C...Expansion coefficients for gluon distribution.
      DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
     1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
     2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
     3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
      DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
     1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
     2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
     3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
 
C...Euler's beta function, requires ordinary Gamma function
      EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
 
C...Leading order proton parton distributions from Gluck, Reya and Vogt.
C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
C...10^-5 < x < 1.
      IF(MSTP(51).EQ.11) THEN
 
C...Determine s expansion variable and some x expressions.
        Q2IN=MIN(1D8,MAX(0.25D0,Q2))
        SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
        SD2=SD**2
        XL=-LOG(X)
        XS=SQRT(X)
 
C...Evaluate valence, gluon and sea distributions.
        XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
     &  X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
     &  (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
     &  (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
        XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
     &  (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
     &  1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
        XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
     &  (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
     &  1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
     &  SQRT(4.066D0*SD**1.218D0*XL)))*
     &  (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
        XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
     &  1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
     &  SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
     &  XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
        XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
     &  (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
     &  EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
     &  SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
        IF(SD.LE.0.888D0) THEN
          XFCHM=0D0
        ELSE
          XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
     &    (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
     &    SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
        ENDIF
        IF(SD.LE.1.351D0) THEN
          XFBOT=0D0
        ELSE
          XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
     &    1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
     &    SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
        ENDIF
 
C...Put into output array.
        XPPR(0)=XFGLU
        XPPR(1)=XFVDD+XFSEA
        XPPR(2)=XFVUD-XFVDD+XFSEA
        XPPR(3)=XFSTR
        XPPR(4)=XFCHM
        XPPR(5)=XFBOT
        XPPR(-1)=XFSEA
        XPPR(-2)=XFSEA
        XPPR(-3)=XFSTR
        XPPR(-4)=XFCHM
        XPPR(-5)=XFBOT
 
C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
      ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
 
C...Determine set, Lambda and x and t expansion variables.
        NSET=MSTP(51)-11
        IF(NSET.EQ.1) ALAM=0.2D0
        IF(NSET.EQ.2) ALAM=0.29D0
        TMIN=LOG(5D0/ALAM**2)
        TMAX=LOG(1D8/ALAM**2)
        T=LOG(MAX(1D0,Q2/ALAM**2))
        VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
        NX=1
        IF(X.LE.0.1D0) NX=2
        IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
        IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
 
C...Chebyshev polynomials for x and t expansion.
        TX(1)=1D0
        TX(2)=VX
        TX(3)=2D0*VX**2-1D0
        TX(4)=4D0*VX**3-3D0*VX
        TX(5)=8D0*VX**4-8D0*VX**2+1D0
        TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
        TT(1)=1D0
        TT(2)=VT
        TT(3)=2D0*VT**2-1D0
        TT(4)=4D0*VT**3-3D0*VT
        TT(5)=8D0*VT**4-8D0*VT**2+1D0
        TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
 
C...Calculate structure functions.
        DO 130 KFL=1,6
          XQSUM=0D0
          DO 120 IT=1,6
            DO 110 IX=1,6
              XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
  110       CONTINUE
  120     CONTINUE
          XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
  130   CONTINUE
 
C...Put into output array.
        XPPR(0)=XQ(4)
        XPPR(1)=XQ(2)+XQ(3)
        XPPR(2)=XQ(1)+XQ(3)
        XPPR(3)=XQ(5)
        XPPR(4)=XQ(6)
        XPPR(-1)=XQ(3)
        XPPR(-2)=XQ(3)
        XPPR(-3)=XQ(5)
        XPPR(-4)=XQ(6)
 
C...Special expansion for bottom (threshold effects).
        IF(MSTP(58).GE.5) THEN
          IF(NSET.EQ.1) TMIN=8.1905D0
          IF(NSET.EQ.2) TMIN=7.4474D0
          IF(T.GT.TMIN) THEN
            VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
            TT(1)=1D0
            TT(2)=VT
            TT(3)=2D0*VT**2-1D0
            TT(4)=4D0*VT**3-3D0*VT
            TT(5)=8D0*VT**4-8D0*VT**2+1D0
            TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
            XQSUM=0D0
            DO 150 IT=1,6
              DO 140 IX=1,6
                XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
  140         CONTINUE
  150       CONTINUE
            XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
            XPPR(-5)=XPPR(5)
          ENDIF
        ENDIF
 
C...Special expansion for top (threshold effects).
        IF(MSTP(58).GE.6) THEN
          IF(NSET.EQ.1) TMIN=11.5528D0
          IF(NSET.EQ.2) TMIN=10.8097D0
          TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
          TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
          IF(T.GT.TMIN) THEN
            VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
            TT(1)=1D0
            TT(2)=VT
            TT(3)=2D0*VT**2-1D0
            TT(4)=4D0*VT**3-3D0*VT
            TT(5)=8D0*VT**4-8D0*VT**2+1D0
            TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
            XQSUM=0D0
            DO 170 IT=1,6
              DO 160 IX=1,6
                XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
  160         CONTINUE
  170       CONTINUE
            XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
            XPPR(-6)=XPPR(6)
          ENDIF
        ENDIF
 
C...Proton parton distributions from Duke, Owens.
C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
      ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
 
C...Determine set, Lambda and s expansion parameter.
        NSET=MSTP(51)-13
        IF(NSET.EQ.1) ALAM=0.2D0
        IF(NSET.EQ.2) ALAM=0.4D0
        Q2IN=MIN(1D6,MAX(4D0,Q2))
        SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
 
C...Calculate structure functions.
        DO 190 KFL=1,5
          DO 180 IS=1,6
            TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
     &      CDO(3,IS,KFL,NSET)*SD**2
  180     CONTINUE
          IF(KFL.LE.2) THEN
            XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
     &      TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
          ELSE
            XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
     &      TS(5)*X**2+TS(6)*X**3)
          ENDIF
  190   CONTINUE
 
C...Put into output arrays.
        XPPR(0)=XQ(5)
        XPPR(1)=XQ(2)+XQ(3)/6D0
        XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
        XPPR(3)=XQ(3)/6D0
        XPPR(4)=XQ(4)
        XPPR(-1)=XQ(3)/6D0
        XPPR(-2)=XQ(3)/6D0
        XPPR(-3)=XQ(3)/6D0
        XPPR(-4)=XQ(4)

      ENDIF
  
      RETURN
      END
 
C*********************************************************************
 
C...PYHFTH
C...Gives threshold attractive/repulsive factor for heavy flavour
C...production.
 
      FUNCTION PYHFTH(SH,SQM,FRATT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYDAT1/,/PYPARS/,/PYINT1/
 
C...Value for alpha_strong.
      IF(MSTP(35).LE.1) THEN
        ALSSG=PARP(35)
      ELSE
        MST115=MSTU(115)
        MSTU(115)=MSTP(36)
        Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
     &  PARP(36)**2)))
        ALSSG=PYALPS(Q2BN)
        MSTU(115)=MST115
      ENDIF
 
C...Evaluate attractive and repulsive factors.
      XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
      FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
      XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
      FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
      PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
      VINT(138)=PYHFTH
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSPLI
C...Splits a hadron remnant into two (partons or hadron + parton)
C...in case it is more complicated than just a quark or a diquark.
 
      SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks. PYDAT1 temporary
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYPARS/,/PYINT1/,/PYDAT1/
C...Local array.
      DIMENSION KFL(3)
 
C...Preliminaries. Parton composition.
      KFA=IABS(KF)
      KFS=ISIGN(1,KF)
      KFL(1)=MOD(KFA/1000,10)
      KFL(2)=MOD(KFA/100,10)
      KFL(3)=MOD(KFA/10,10)
      IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
        KFL(2)=INT(1.5D0+PYR(0))
        IF(MINT(105).EQ.333) KFL(2)=3
        IF(MINT(105).EQ.443) KFL(2)=4
        KFL(3)=KFL(2)
      ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
        KFL(2)=2
        KFL(3)=2
      ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
        KFL(2)=1
        KFL(3)=1
      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
          NTRY=0
  100     NTRY=NTRY+1
          CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
          IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
            GOTO 100
          ELSEIF(KFLCH.EQ.0) THEN
            CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF
          KFLSP=KFL(3)
        ELSE
          NTRY=0
  110     NTRY=NTRY+1
          CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
          IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
            GOTO 110
          ELSEIF(KFLCH.EQ.0) THEN
            CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF
          KFLSP=KFL(2)
        ENDIF
 
C...Subdivide baryon.
      ELSE
        NAGR=0
        DO 120 J=1,3
          IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
  120   CONTINUE
        IF(NAGR.GE.1) THEN
          RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
          IAGR=0
          DO 130 J=1,3
            IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
            IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
  130     CONTINUE
        ELSE
          IAGR=1.00001D0+2.99998D0*PYR(0)
        ENDIF
        ID1=1
        IF(IAGR.EQ.1) ID1=2
        IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
        ID2=6-IAGR-ID1
        KSP=3
        IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
          IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
        ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
          IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
        ELSEIF(MOD(KFA,10).EQ.2) THEN
          IF(IAGR.EQ.1) KSP=1
          IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
        ENDIF
        KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
        IF(KFLR.EQ.21) THEN
          KFLCH=KFL(IAGR)
        ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
          NTRY=0
  140     NTRY=NTRY+1
          CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
          IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
            GOTO 140
          ELSEIF(KFLCH.EQ.0) THEN
            CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF
        ELSEIF(NAGR.EQ.0) THEN
          NTRY=0
  150     NTRY=NTRY+1
          CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
          IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
            GOTO 150
          ELSEIF(KFLCH.EQ.0) THEN
            CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF
          KFLSP=KFL(IAGR)
        ENDIF
      ENDIF
 
C...Add on correct sign for result.
      KFLCH=KFLCH*KFS
      KFLSP=KFLSP*KFS
 
      RETURN
      END

C*********************************************************************
 
C...PYGAMM
C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
C...(Dover, 1965) 6.1.36.
 
      FUNCTION PYGAMM(X)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Local array and data.
      DIMENSION B(8)
      DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
     &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
 
      NX=INT(X)
      DX=X-NX
 
      PYGAMM=1D0
      DXP=1D0
      DO 100 I=1,8
        DXP=DXP*DX
        PYGAMM=PYGAMM+B(I)*DXP
  100 CONTINUE
      IF(X.LT.1D0) THEN
        PYGAMM=PYGAMM/X
      ELSE
        DO 110 IX=1,NX-1
          PYGAMM=(X-IX)*PYGAMM
  110   CONTINUE
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYWAUX
C...Calculates real and imaginary parts of the auxiliary functions W1
C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
C...der Bij, Nucl. Phys. B297 (1988) 221.
 
      SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
      ASINH(X)=LOG(X+SQRT(X**2+1D0))
      ACOSH(X)=LOG(X+SQRT(X**2-1D0))
 
      IF(EPS.LT.0D0) THEN
        IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
        IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
        WIM=0D0
      ELSEIF(EPS.LT.1D0) THEN
        IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
        IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
        IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
        IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
      ELSE
        IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
        IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
        WIM=0D0
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYI3AU
C...Calculates real and imaginary parts of the auxiliary function I3;
C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
C...Nucl. Phys. B297 (1988) 221.
 
      SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
      BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
      IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
 
      IF(EPS.LT.0D0) THEN
        IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
          F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
     &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
     &    PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
     &    PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
     &    LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
     &    LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
     &    LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
     &    EPS))
        ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
          F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
     &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
     &    PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
     &    PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
     &    0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
     &    LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
     &    LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
        ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
          F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
     &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
     &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
     &    PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
     &    0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
     &    LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
     &    LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
        ELSE
          F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
     &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
     &    PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
     &    LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
     &    LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
        ENDIF
        F3IM=0D0
      ELSEIF(EPS.LT.1D0) THEN
        IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
          F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
     &    PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
     &    PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
     &    PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
     &    (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
     &    (0.25D0*(RAT+1D0)*EPS))
          F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
     &    (0.25D0*(RAT+1D0)*EPS))
        ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
          F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
     &    PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
     &    PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
     &    PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
     &    LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
     &    LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
          F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
        ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
          F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
     &    PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
     &    PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
     &    PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
     &    LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
     &    (1D0+0.25D0*RAT*EPS-GA))
          F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
     &    (1D0+0.25D0*RAT*EPS-GA))
        ELSE
          F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
     &    PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
     &    PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
     &    LOG((GA+BE-1D0)/(BE-GA))
          F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
        ENDIF
      ELSE
        RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
        RCTHE=RSQ*(1D0-2D0*BE/EPS)
        RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
        RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
        RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
        R=SQRT(RSQ)
        THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
        PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
        F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
     &  PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
     &  (PHI-THE)*(PHI+THE-PARU(1))
        F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
     &  PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
      ENDIF
 
      Y3RE=2D0/(2D0*BE-1D0)*F3RE
      Y3IM=2D0/(2D0*BE-1D0)*F3IM
 
      RETURN
      END
 
C***********************************************************************
 
C...PYSPEN
C...Calculates real and imaginary part of Spence function; see
C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
 
      FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local array and data.
      DIMENSION B(0:14)
      DATA B/
     &1.000000D+00,        -5.000000D-01,         1.666667D-01,
     &0.000000D+00,        -3.333333D-02,         0.000000D+00,
     &2.380952D-02,         0.000000D+00,        -3.333333D-02,
     &0.000000D+00,         7.575757D-02,         0.000000D+00,
     &-2.531135D-01,         0.000000D+00,         1.166667D+00/
 
      XRE=XREIN
      XIM=XIMIN
      IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
        IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
        IF(IREIM.EQ.2) PYSPEN=0D0
        RETURN
      ENDIF
 
      XMOD=SQRT(XRE**2+XIM**2)
      IF(XMOD.LT.1D-6) THEN
        IF(IREIM.EQ.1) PYSPEN=0D0
        IF(IREIM.EQ.2) PYSPEN=0D0
        RETURN
      ENDIF
 
      XARG=SIGN(ACOS(XRE/XMOD),XIM)
      SP0RE=0D0
      SP0IM=0D0
      SGN=1D0
      IF(XMOD.GT.1D0) THEN
        ALGXRE=LOG(XMOD)
        ALGXIM=XARG-SIGN(PARU(1),XARG)
        SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
        SP0IM=-ALGXRE*ALGXIM
        SGN=-1D0
        XMOD=1D0/XMOD
        XARG=-XARG
        XRE=XMOD*COS(XARG)
        XIM=XMOD*SIN(XARG)
      ENDIF
      IF(XRE.GT.0.5D0) THEN
        ALGXRE=LOG(XMOD)
        ALGXIM=XARG
        XRE=1D0-XRE
        XIM=-XIM
        XMOD=SQRT(XRE**2+XIM**2)
        XARG=SIGN(ACOS(XRE/XMOD),XIM)
        ALGYRE=LOG(XMOD)
        ALGYIM=XARG
        SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
        SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
        SGN=-SGN
      ENDIF
 
      XRE=1D0-XRE
      XIM=-XIM
      XMOD=SQRT(XRE**2+XIM**2)
      XARG=SIGN(ACOS(XRE/XMOD),XIM)
      ZRE=-LOG(XMOD)
      ZIM=-XARG
 
      SPRE=0D0
      SPIM=0D0
      SAVERE=1D0
      SAVEIM=0D0
      DO 100 I=0,14
        IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
        TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
        TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
        SAVERE=TERMRE
        SAVEIM=TERMIM
        SPRE=SPRE+B(I)*TERMRE
        SPIM=SPIM+B(I)*TERMIM
  100 CONTINUE
 
  110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
      IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
 
      RETURN
      END
 
C***********************************************************************
 
C...PYQQBH
C...Calculates the matrix element for the processes
C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
C...REDUCE output and part of the rest courtesy Z. Kunszt, see
C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
 
      SUBROUTINE PYQQBH(WTQQBH)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
C...Local arrays and function.
      DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
      DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
     &PP(I,3)*PP(J,3)
 
C...Mass parameters.
      WTQQBH=0D0
      ISUB=MINT(1)
      SHPR=SQRT(VINT(26))*VINT(1)
      PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
      PH=SQRT(VINT(21))*VINT(1)
      SPQ=PQ**2
      SPH=PH**2
 
C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
      DO 100 I=1,2
        PT=SQRT(MAX(0D0,VINT(197+5*I)))
        PP(I,1)=PT*COS(VINT(198+5*I))
        PP(I,2)=PT*SIN(VINT(198+5*I))
  100 CONTINUE
      PP(3,1)=-PP(1,1)-PP(2,1)
      PP(3,2)=-PP(1,2)-PP(2,2)
      PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
      PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
      PMS3=SPH+PP(3,1)**2+PP(3,2)**2
      PMT3=SQRT(PMS3)
      PP(3,3)=PMT3*SINH(VINT(211))
      PP(3,4)=PMT3*COSH(VINT(211))
      PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
      PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
     &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
      PP(2,3)=-PP(1,3)-PP(3,3)
      PP(1,4)=SQRT(PMS1+PP(1,3)**2)
      PP(2,4)=SQRT(PMS2+PP(2,3)**2)
 
C...Set up incoming kinematics and derived momentum combinations.
      DO 110 I=4,5
        PP(I,1)=0D0
        PP(I,2)=0D0
        PP(I,3)=-0.5D0*SHPR*(-1)**I
        PP(I,4)=-0.5D0*SHPR
  110 CONTINUE
      DO 120 J=1,4
        PP(6,J)=PP(1,J)+PP(2,J)
        PP(7,J)=PP(1,J)+PP(3,J)
        PP(8,J)=PP(1,J)+PP(4,J)
        PP(9,J)=PP(1,J)+PP(5,J)
        PP(10,J)=-PP(2,J)-PP(3,J)
        PP(11,J)=-PP(2,J)-PP(4,J)
        PP(12,J)=-PP(2,J)-PP(5,J)
        PP(13,J)=-PP(4,J)-PP(5,J)
  120 CONTINUE
 
C...Derived kinematics invariants.
      X1=DOT(1,2)
      X2=DOT(1,3)
      X3=DOT(1,4)
      X4=DOT(1,5)
      X5=DOT(2,3)
      X6=DOT(2,4)
      X7=DOT(2,5)
      X8=DOT(3,4)
      X9=DOT(3,5)
      X10=DOT(4,5)
 
C...Propagators.
      SS1=DOT(7,7)-SPQ
      SS2=DOT(8,8)-SPQ
      SS3=DOT(9,9)-SPQ
      SS4=DOT(10,10)-SPQ
      SS5=DOT(11,11)-SPQ
      SS6=DOT(12,12)-SPQ
      SS7=DOT(13,13)
      DX(1)=SS1*SS6
      DX(2)=SS2*SS6
      DX(3)=SS2*SS4
      DX(4)=SS1*SS5
      DX(5)=SS3*SS5
      DX(6)=SS3*SS4
      DX(7)=SS7*SS1
      DX(8)=SS7*SS4
 
C...Define colour coefficients for g + g -> Q + Qbar + H.
      IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
        DO 140 I=1,3
          DO 130 J=1,3
            CLR(I,J)=16D0/3D0
            CLR(I+3,J+3)=16D0/3D0
            CLR(I,J+3)=-2D0/3D0
            CLR(I+3,J)=-2D0/3D0
  130     CONTINUE
  140   CONTINUE
        DO 160 L=1,2
          DO 150 I=1,3
            CLR(I,6+L)=-6D0
            CLR(I+3,6+L)=6D0
            CLR(6+L,I)=-6D0
            CLR(6+L,I+3)=6D0
  150     CONTINUE
  160   CONTINUE
        DO 180 K1=1,2
          DO 170 K2=1,2
            CLR(6+K1,6+K2)=12D0
  170     CONTINUE
  180   CONTINUE
 
C...Evaluate matrix elements for g + g -> Q + Qbar + H.
        FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
     &  X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
     &  X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
        FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
     &  *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
     &  X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
     &  X10)
        FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
     &  X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
     &  +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
     &  -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
     &  -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
     &  X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
        FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
     &  X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
     &  )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
     &  4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
     &  X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
        FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
     &  X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
     &  X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
     &  *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
     &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
     &  X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
     &  +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
     &  X4*X6*X5)
        FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
     &  X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
     &  X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
     &  *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
     &  +X4*X9*X5+X4*X5**2)
        FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
     &  PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
     &  X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
     &  X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
     &  X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
     &  X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
        FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
     &  PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
     &  2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
     &  X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
     &  +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
     &  X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
     &  X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
     &  X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
     &  X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
        FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
     &  X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
        FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
     &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
     &  X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
     &  X6)
        FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
     &  X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
     &  X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
     &  *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
     &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
     &  *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
     &  X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
     &  X5+X4*X6*X5)
        FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
     &  *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
     &  2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
     &  X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
     &  X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
     &  *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
     &  X6**2)
        FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
     &  X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
     &  X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
     &  X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
     &  2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
     &  X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
     &  -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
     &  X4*X6*X5)
        FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
     &  2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
     &  X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
     &  X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
     &  *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
     &  +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
     &  -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
     &  X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
     &  X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
     &  X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
     &  *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
        FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
     &  2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
     &  X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
     &  X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
     &  *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
     &  X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
     &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
     &  X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
     &  *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
     &  X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
     &  X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
        FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
     &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
     &  X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
        FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
     &  X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
     &  X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
     &  *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
     &  +X3*X8*X5+X3*X5**2)
        FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
     &  X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
     &  X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
     &  *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
     &  **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
     &  *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
     &  X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
     &  X5+X4*X6*X5)
        FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
     &  X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
     &  )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
     &  X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
     &  X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
        FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
     &  PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
     &  X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
     &  X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
     &  X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
     &  X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
     &  X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
     &  *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
     &  +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
        FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
     &  PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
     &  4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
     &  +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
     &  X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
     &  *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
        FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
     &  X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
     &  X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
        FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
     &  *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
     &  X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
     &  X10)
        FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
     &  X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
     &  +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
     &  -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
     &  -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
     &  X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
        FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
     &  *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
     &  X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
     &  X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
     &  X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
     &  X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
        FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
     &  *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
     &  +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
     &  *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
     &  X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
     &  *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
     &  *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
     &  *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
     &  X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
        FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
     &  X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
        FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
     &  *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
     &  X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
     &  X7)
        FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
     &  4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
     &  X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
     &  3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
     &  2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
     &  2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
     &  X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
     &  *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
     &  X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
     &  X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
     &  *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
        FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
     &  4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
     &  X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
     &  2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
     &  X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
     &  3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
     &  X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
     &  X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
     &  *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
     &  X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
     &  X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
        FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
     &  +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
     &  X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
        FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
     &  *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
     &  -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
     &  -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
     &  7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
     &  *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
     &  *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
     &  **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
     &  2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
        FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
     &  *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
     &  X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
     &  X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
     &  *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
     &  X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
        FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
     &  X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
     &  X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
     &  *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
     &  *X6)
        FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
     &  10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
     &  X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
     &  X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
     &  X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
     &  +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
     &  7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
        FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
     &  *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
     &  *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
     &  X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
     &  X8)
        FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
     &  X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
     &  )+2*X2*(-X10*X5+X9*X6+X8*X7)
        FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
     &  X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
     &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
     &  X9*X5)
        FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
     &  X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
     &  *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
     &  X8*X5)
        FM(9,10)=0.5D0*(FMXX+FM(9,10))
        FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
     &  X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
     &  )+2*X5*(-X10*X2+X9*X3+X8*X4)
 
C...Repackage matrix elements.
        DO 200 I=1,8
          DO 190 J=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)
      IMPLICIT INTEGER(I-N)
      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)
      COMMON/PYHTRI/HHH(7)
      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)
 1    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),MWIDSU(36),MDCYSU(36)
      SAVE INIT,MWIDSU,MDCYSU
      DATA KFSUSY/
     &1000001,2000001,1000002,2000002,1000003,2000003,
     &1000004,2000004,1000005,2000005,1000006,2000006,
     &1000011,2000011,1000012,2000012,1000013,2000013,
     &1000014,2000014,1000015,2000015,1000016,2000016,
     &1000021,1000022,1000023,1000025,1000035,1000024,
     &1000037,1000039,     25,     35,     36,     37/
      DATA INIT/0/

C...Do nothing if SUSY not requested.
      IMSSM=IMSS(1)
      IF(IMSSM.EQ.0) RETURN

C...Save copy of MWID(KC) and MDCY(KC,1) values before 
C...they are set to zero for the LSP.
      IF(INIT.EQ.0) THEN
        INIT=1
        DO 105 I=1,36
          KF=KFSUSY(I)
          KC=PYCOMP(KF)
          MWIDSU(I)=MWID(KC)
          MDCYSU(I)=MDCY(KC,1)
  105   CONTINUE
      ENDIF
  
C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
      DO 107 I=1,36
        KF=KFSUSY(I)
        KC=PYCOMP(KF)
        IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
          MWID(KC)=MWIDSU(I)
          MDCY(KC,1)=MDCYSU(I)
        ENDIF
  107 CONTINUE

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
      SBMA=SIN(BE-AL)
      SAPB=SIN(AL+BE)
      CAPB=COS(AL+BE)
      CBMA=COS(BE-AL)
      S2A=SIN(2D0*AL)
      C2A=COS(2D0*AL)
      C2B=COSB**2-SINB**2
C...tanb (used for H+)
      PARU(141)=TANB
 
C...Firstly: h
C...Coupling to d-type quarks
      PARU(161)=SINA/COSB
C...Coupling to u-type quarks
      PARU(162)=-COSA/SINB
C...Coupling to leptons
      PARU(163)=PARU(161)
C...Coupling to Z
      PARU(164)=SBMA
C...Coupling to W
      PARU(165)=PARU(164)
 
C...Secondly: H
C...Coupling to d-type quarks
      PARU(171)=-COSA/COSB
C...Coupling to u-type quarks
      PARU(172)=-SINA/SINB
C...Coupling to leptons
      PARU(173)=PARU(171)
C...Coupling to Z
      PARU(174)=CBMA
C...Coupling to W
      PARU(175)=PARU(174)
C...Coupling to h
C      PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
      HHH(3)=HHH(3)+HHH(4)+HHH(5)
      PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
     1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
     2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
     3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
C...Coupling to H+
C...Define later
C      PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
      PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
     1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
     2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
     3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
C...Coupling to A
C      PARU(177)=COS(2D0*BE)*COS(BE+AL)
      PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
     1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
     2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
     3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
C...Coupling to H+
      PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
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)
C...Find the LSP or NLSP for a gravitino LSP
      ILSP=0
      PMLSP=1D20
      DO 150 I=1,36
        KF=KFSUSY(I)
        IF(KF.EQ.1000039) GOTO 150
        KC=PYCOMP(KF)
        IF(PMAS(KC,1).LT.PMLSP) THEN
          ILSP=I
          PMLSP=PMAS(KC,1)
        ENDIF
  150 CONTINUE
      DO 210 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)
          IF(I.EQ.ILSP) LKNT=0
 
C...Neutralino decays.
        ELSEIF(I.GE.26.AND.I.LE.29) THEN
          CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
C...chi10 stable or chi10 -> gravitino + gamma.
          IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
            PMAS(KC,2)=1D-6
            MDCY(KC,1)=0
            MWID(KC)=0
          ENDIF
 
C...Chargino decays.
        ELSEIF(I.GE.30.AND.I.LE.31) THEN
          CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
 
C...Gravitino is stable.
        ELSEIF(I.EQ.32) THEN
          MDCY(KC,1)=0
          MWID(KC)=0
 
C...Higgs decays.
        ELSEIF(I.GE.33.AND.I.LE.36) THEN
C...Calculate decays to non-SUSY particles.
          CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
          LKNT=0
          DO 160 I1=0,100
            XLAM(I1)=0D0
  160     CONTINUE
          DO 180 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 180
            XLAM(I1)=WDTP(I1)
            XLAM(0)=XLAM(0)+XLAM(I1)
            DO 170 J1=1,3
              IDLAM(I1,J1)=KFDP(K1,J1)
  170       CONTINUE
            LKNT=LKNT+1
  180     CONTINUE
C...Add the decays to SUSY particles.
          CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
        ENDIF
C...Zero the branching ratios for use in loop mode
C...thanks to K. Matchev (FNAL)
        DO 185 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
          BRAT(IDC)=0D0
  185   CONTINUE
 
C...Set stable particles.
        IF(LKNT.EQ.0) THEN
          MDCY(KC,1)=0
          MWID(KC)=0
          PMAS(KC,2)=1D-6
          PMAS(KC,3)=1D-5
          PMAS(KC,4)=0D0
 
C...Store branching ratios in the standard tables.
        ELSE
          IDC=MDCY(KC,2)+MDCY(KC,3)-1
          DELM=1D6
          DO 200 IL=1,LKNT
            IDCSV=IDC
  190       IDC=IDC+1
            BRAT(IDC)=0D0
            IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
            IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
     &      KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
              BRAT(IDC)=XLAM(IL)/XLAM(0)
              XMDIF=PMAS(KC,1)
              IF(MDME(IDC,1).GE.1) THEN
                XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
     &          PMAS(PYCOMP(KFDP(IDC,2)),1)
                IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
     &          PMAS(PYCOMP(KFDP(IDC,3)),1)
              ENDIF
              IF(I.LE.32) THEN
                IF(XMDIF.GE.0D0) THEN
                  DELM=MIN(DELM,XMDIF)
                ELSE
                  WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
                  WRITE(MSTU(11),*) ' KF = ',KF
                  WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
                ENDIF
              ENDIF
              GOTO 200
            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 200
            ELSE
              GOTO 190
            ENDIF
  200     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
  210 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)
      IMPLICIT INTEGER(I-N)
      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/
 
      IMSS(5)=0
      XMT=PMAS(6,1)
      XMZ2=PMAS(23,1)**2
      XMW2=PMAS(24,1)**2
      TANB=RMSS(5)
      BETA=ATAN(TANB)
      XW=PARU(102)
      XMG=RMSS(1)
      XMG2=XMG*XMG
      XM0=RMSS(8)
      XM02=XM0*XM0
      AT=-RMSS(16)
      RMSS(15)=AT
      RMSS(17)=AT
      COSB=COS(BETA)
      SINB=TANB/SQRT(TANB**2+1D0)
      COSB=SINB/TANB
 
      DTERM=XMZ2*COS(2D0*BETA)
      XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
      XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
      RMSS(6)=XMEL
      RMSS(7)=XMER
      XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
      XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
      XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
      XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
      DO 100 I=1,5,2
        PMAS(PYCOMP(KSUSY1+I),1)=XMDL
        PMAS(PYCOMP(KSUSY2+I),1)=XMDR
        PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
        PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
  100 CONTINUE
      XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
      IF(XARG.LT.0D0) THEN
        WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
     &  ' FROM THE SUM RULE. '
        WRITE(MSTU(11),*) '  TRY A SMALLER VALUE OF TAN(BETA). '
        RETURN
      ELSE
        XARG=SQRT(XARG)
      ENDIF
      DO 110 I=11,15,2
        PMAS(PYCOMP(KSUSY1+I),1)=XMEL
        PMAS(PYCOMP(KSUSY2+I),1)=XMER
        PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
        PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
  110 CONTINUE
      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
C      XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2)
C.....
      XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
     &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
C      XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2
C.....
      XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
      SAVE /PYMSSM/
 
C...Local variables.
      DOUBLE PRECISION PI,R
      DOUBLE PRECISION TOL
      DOUBLE PRECISION CI(3)
      EXTERNAL PYALPS
      DOUBLE PRECISION PYALPS
      DATA TOL/0.001D0/
      DATA PI,R/3.141592654D0,.61803399D0/
      DATA CI/0.47D0,0.07D0,0.02D0/
 
      C=1D0-R
      CA=CI(ID)
      AG=(0.71D0)**2/4D0/PI
      AG=RMSS(20)
      XM0=RMSS(8)
      XMG=RMSS(1)
      XM02=XM0*XM0
      XMG2=XMG*XMG
 
      AS=PYALPS(XM02+6D0*XMG2)
      CG=8D0/9D0*((AS/AG)**2-1D0)
      BX=XM02+(CA+CG)*XMG2+DTERM
      AX=MIN(50D0**2,0.5D0*BX)
      CX=MAX(2000D0**2,2D0*BX)
 
      X0=AX
      X3=CX
      IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
        X1=BX
        X2=BX+C*(CX-BX)
      ELSE
        X2=BX
        X1=BX-C*(BX-AX)
      ENDIF
      AS1=PYALPS(X1)
      CG=8D0/9D0*((AS1/AG)**2-1D0)
      F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
      AS2=PYALPS(X2)
      CG=8D0/9D0*((AS2/AG)**2-1D0)
      F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
  100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
        IF(F2.LT.F1) THEN
          X0=X1
          X1=X2
          X2=R*X1+C*X3
          F1=F2
          AS2=PYALPS(X2)
          CG=8D0/9D0*((AS2/AG)**2-1D0)
          F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
        ELSE
          X3=X2
          X2=X1
          X1=R*X2+C*X0
          F2=F1
          AS1=PYALPS(X1)
          CG=8D0/9D0*((AS1/AG)**2-1D0)
          F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
        ENDIF
        GOTO 100
      ENDIF
      IF(F1.LT.F2) THEN
        PYRNMQ=X1
        XMIN=X1
      ELSE
        PYRNMQ=X2
        XMIN=X2
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
      SAVE /PYMSSM/
 
C...Local variables.
      DOUBLE PRECISION XMT
      DOUBLE PRECISION PI,R
      DOUBLE PRECISION TOL
      EXTERNAL PYALPS
      DOUBLE PRECISION 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)
      IMPLICIT INTEGER(I-N)
      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 BOTTOM 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
C SAME FOR TAU SLEPTON
        CTT=RMSS(28)
        CTT2=CTT**2
        STT2=1D0-CTT2
        STT=SQRT(STT2)
        XM12=RMSS(14)**2
        XM22=RMSS(13)**2
        XMQL2=CTT2*XM12+STT2*XM22
        XMQR2=STT2*XM12+CTT2*XM22
        XMFR=PMAS(15,1)
        XMF2=XMFR**2
        ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
        ATMT=SQRT(XMF2)*(ATAU+XMU*TANB)
        XTEST=(XMQL2-XMQR2)*(CTT2-STT2)
        IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN
         STT=-STT
         ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2)
        ENDIF
        RMSS(17)=ATAU
C......SUBTRACT OUT D-TERM AND FERMION MASS
        XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
        XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
        IF(XMQL2.GE.0D0) THEN
          RMSS(13)=SQRT(XMQL2)
        ELSE
          RMSS(13)=-SQRT(-XMQL2)
        ENDIF
        IF(XMQR2.GE.0D0) THEN
          RMSS(14)=SQRT(XMQR2)
        ELSE
          RMSS(14)=-SQRT(-XMQR2)
        ENDIF
      ENDIF
      DO 170 L=1,3
        AMQL=RMSS(ID1(L))
        IF(AMQL.LT.0D0) THEN
          XMQL2=-AMQL**2
        ELSE
          XMQL2=AMQL**2
        ENDIF
        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)
        DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
        IF(DETM.LT.0D0) THEN
          WRITE(MSTU(11),*) ID1(L),DETM
          CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION ')
        ENDIF
        SAME=0.5D0*(AM2(1,1)+AM2(2,2))
        DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
        XMF12=SAME-DIFF
        XMF22=SAME+DIFF
        IT=0
        IF(XMF22-XMF12.GT.0D0) THEN
          RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
          RT(2,2) = RT(1,1)
          RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
     &    AM2(1,2)/(XMF22-XMF12))
          RT(2,1) = -RT(1,2)
        ELSE
          RT(1,1) = 1D0
          RT(2,2) = RT(1,1)
          RT(1,2) = 0D0
          RT(2,1) = -RT(1,2)
        ENDIF
  100   CONTINUE
        IT=IT+1
 
        DO 140 I=1,2
          DO 130 JJ=1,2
            DI(I,JJ)=0D0
            DO 120 II=1,2
              DO 110 J=1,2
                DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
  110         CONTINUE
  120       CONTINUE
  130     CONTINUE
  140   CONTINUE
 
        IF(DI(1,1).GT.DI(2,2)) THEN
          WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
          WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
          WRITE(MSTU(11),*) AM2
          WRITE(MSTU(11),*) DI
          WRITE(MSTU(11),*) RT
          DI(1,1)=-RT(2,1)
          DI(2,2)=RT(1,2)
          DI(1,2)=-RT(2,2)
          DI(2,1)=RT(1,1)
          DO 160 I=1,2
            DO 150 J=1,2
              RT(I,J)=DI(I,J)
  150       CONTINUE
  160     CONTINUE
          GOTO 100
        ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
          WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
     &    ' OFF DIAGONAL ELEMENTS '
          WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
          WRITE(MSTU(11),*) DI
          WRITE(MSTU(11),*) ' ROTATION = ',RT
C...STOP
        ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
          WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
     &    ' NEGATIVE MASSES '
          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)
      IMPLICIT INTEGER(I-N)
      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
          RMSS(2)=XM2
        ELSEIF(IOPT.EQ.3) THEN
          XM1=XM2*5D0/3D0*A1/A2
          RMSS(1)=XM1
        ENDIF
        XM3=PYRNM3(XM2/A2)
        RMSS(3)=XM3
        IF(XM3.LE.0D0) THEN
          WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
          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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local variables.
      DOUBLE PRECISION PI,R
      DOUBLE PRECISION TOL
      EXTERNAL PYALPS
      DOUBLE PRECISION 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)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Arrays: in call and local.
      DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
 
C...Coefficients of fourth-degree equation from matrix.
C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
      B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
      B2=0D0
      DO 110 I=1,3
        DO 100 J=I+1,4
          B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
  100   CONTINUE
  110 CONTINUE
      B1=0D0
      B0=0D0
      DO 120 I=1,4
        I1=MOD(I,4)+1
        I2=MOD(I+1,4)+1
        I3=MOD(I+2,4)+1
        B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
     &  A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
     &  A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
        B0=B0+(-1D0)**(I+1)*A(1,I)*(
     &  A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
     &  A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
     &  A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
  120 CONTINUE
 
C...Coefficients of third-degree equation needed for
C...separation into two second-degree equations.
C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
      C2=-B2
      C1=B1*B3-4D0*B0
      C0=-B1**2-B0*B3**2+4D0*B0*B2
      CQ=C1/3D0-C2**2/9D0
      CR=C1*C2/6D0-C0/2D0-C2**3/27D0
      CQR=CQ**3+CR**2
 
C...Cases with one or three real roots.
      IF(CQR.GE.0D0) THEN
        S1=(CR+SQRT(CQR))**(1D0/3D0)
        S2=(CR-SQRT(CQR))**(1D0/3D0)
        U=S1+S2-C2/3D0
      ELSE
        SABS=SQRT(-CQ)
        THE=ACOS(CR/SABS**3)/3D0
        SRE=SABS*COS(THE)
        U=2D0*SRE-C2/3D0
      ENDIF
 
C...Find and solve two second-degree equations.
      P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
      P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
      Q1=U/2D0+SQRT(U**2/4D0-B0)
      Q2=U/2D0-SQRT(U**2/4D0-B0)
      IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
        QSAV=Q1
        Q1=Q2
        Q2=QSAV
      ENDIF
      X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
      X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
      X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
      X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
 
C...Order eigenvalues in asceding mass.
      W(1)=X(1)
      DO 150 I1=2,4
        DO 130 I2=I1-1,1,-1
          IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
          W(I2+1)=W(I2)
  130   CONTINUE
  140   W(I2+1)=X(I1)
  150 CONTINUE
 
C...Find equation system for eigenvectors.
      DO 250 I=1,4
        DO 170 J1=1,4
          D(J1,J1)=A(J1,J1)-W(I)
          DO 160 J2=J1+1,4
            D(J1,J2)=A(J1,J2)
            D(J2,J1)=A(J2,J1)
  160     CONTINUE
  170   CONTINUE
 
C...Find largest element in matrix.
        DAMAX=0D0
        DO 190 J1=1,4
          DO 180 J2=1,4
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
            JA=J1
            JB=J2
            DAMAX=ABS(D(J1,J2))
  180     CONTINUE
  190   CONTINUE
 
C...Subtract others by multiple of row selected above.
        DAMAX=0D0
        DO 210 J3=JA+1,JA+3
          J1=J3-4*((J3-1)/4)
          RL=D(J1,JB)/D(JA,JB)
          DO 200 J2=1,4
            D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
            JC=J1
            JD=J2
            DAMAX=ABS(D(J1,J2))
  200     CONTINUE
  210   CONTINUE
 
C...Do one more subtraction of a row.
        DAMAX=0D0
        DO 230 J3=JC+1,JC+3
          J1=J3-4*((J3-1)/4)
          IF(J1.EQ.JA) GOTO 230
          RL=D(J1,JD)/D(JC,JD)
          DO 220 J2=1,4
            IF(J2.EQ.JB) GOTO 220
            D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
            IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
            JE=J1
            DAMAX=ABS(D(J1,J2))
  220     CONTINUE
  230   CONTINUE
 
C...Construct unnormalized eigenvector.
        JF1=JD+1-4*(JD/4)
        JF2=JD+2-4*((JD+1)/4)
        IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
        IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
        E(JF1)=-D(JE,JF2)
        E(JF2)=D(JE,JF1)
        E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
        E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
     &  D(JA,JB)
 
C...Normalize and fill in final array.
        EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
        SGN=(-1D0)**INT(PYR(0)+0.5D0)
        DO 240 J=1,4
          Z(I,J)=SGN*E(J)/EA
  240   CONTINUE
  250 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYHGGM
C...Determines the Higgs boson mass spectrum using several inputs.
 
      SUBROUTINE PYHGGM(ALPHA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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
        IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
         WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
         WRITE(MSTU(11),*) ' STOP1 MASSES = ',
     & PMAS(PYCOMP(1000006),1),DSTOP2
        ENDIF
        IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
         WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
         WRITE(MSTU(11),*) ' STOP2 MASSES = ',
     & PMAS(PYCOMP(2000006),1),DSTOP1
        ENDIF
        IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
         WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
         WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
     & PMAS(PYCOMP(1000005),1),DSBOT2
        ENDIF
        IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
         WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
         WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
     & PMAS(PYCOMP(2000005),1),DSBOT1
        ENDIF
 
      ENDIF
 
      ALPHA=ACOS(DCA)
 
      PMAS(25,1)=DMH
      PMAS(35,1)=DHM
      PMAS(36,1)=DMA
      PMAS(37,1)=DMHCH
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSUBH
C...This routine computes the renormalization group improved
C...values of Higgs masses and couplings in the MSSM.
 
C...Program based on the work by M. Carena, J.R. Espinosa,
c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
 
C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
C...All masses in GeV units. MA is the CP-odd Higgs mass,
C...MTOP is the physical top mass, MQ and MUR are the soft
C...supersymmetry breaking mass parameters of left handed
C...and right handed stops respectively, AU and AD are the
C...stop and sbottom trilinear soft breaking terms,
C...respectively,  and MU is the supersymmetric
C...Higgs mass parameter. We use the  conventions from
C...the physics report of Haber and Kane: left right
C...stop mixing term proportional to (AU - MU/TANB)
C...We use as input TANB defined at the scale MTOP
 
C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
C...where MH and HM are the lightest and heaviest CP-even
C...Higgs masses, MHCH is the charged Higgs mass and
C...ALPHA is the Higgs mixing angle
C...TANBA is the angle TANB at the CP-odd Higgs mass scale
 
C...Range of validity:
C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
C...are the sbottom  mass eigenvalues, respectively. This
C...range automatically excludes the existence of tachyons.
C...For the charged Higgs mass computation, the method is
C...valid if
C...2 * |MB * AD* TANB|  < M_SUSY**2,  2 * |MTOP * AU| < M_SUSY**2
C...2 * |MB * MU * TANB| < M_SUSY**2,  2 * |MTOP * MU| < M_SUSY**2
C...where M_SUSY**2 is the average of the squared stop mass
C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
C...masses have been assumed to be of order of the stop ones
C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
 
      SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
     &XMHCH,SA,CA,TANBA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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/PYHTRI/HHH(7)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Local variables.
      DOUBLE PRECISION PYALEM,PYALPS
      DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
      DOUBLE PRECISION XMHCH,SA,CA
      DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
      DOUBLE PRECISION Q02
      DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
      DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
      DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
      DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
      DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
      DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
      DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
      DOUBLE PRECISION 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)
      HHH(1)=XLAM1
      HHH(2)=XLAM2
      HHH(3)=XLAM3
      HHH(4)=XLAM4
      HHH(5)=XLAM5
      HHH(6)=XLAM6
      HHH(7)=XLAM7
      TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
     &2D0* XLAM6*SINBT*COSBT
     &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
     &+ XLAM5*COSBT**2)
      DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
     &XLAM6*COSBT**2
     &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
     &2D0* XLAM6* COSBT*SINBT
     &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
     &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
     &((XLAM1* COSBT**2 +2D0*
     &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
     &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
     &*SINBT**2
     &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
     &+ XLAM4) + XLAM6*COSBT**2
     &+ XLAM7* SINBT**2))
 
      XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
      XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
      XHM = SQRT(XHM2)
      XMH = SQRT(XMH2)
      XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
      XMHCH = SQRT(XMHCH2)
 
      SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
     &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
     &XLAM6* COSBT*SINBT
     &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
     &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
     &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
     &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
 
      COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
     &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
     &XMA**2*SINBT*COSBT))/2D0**0.5D0/
     &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
     &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
     &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
     &XLAM6* COSBT*SINBT
     &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
     &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
     &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
 
      SA = -SINALP
      CA = -COSALP
 
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPOLE
C...This subroutine computes the CP-even higgs and CP-odd pole
c...Higgs masses and mixing angles.
 
C...Program based on the work by M. Carena, M. Quiros
C...and C.E.M. Wagner, "Effective potential methods and
C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
 
C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
C...AT,AB,MU
C...where MCHI is the largest chargino mass, MA is the running
C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
C...expectaion values at the scale MTOP, MQ is the third generation
C...left handed squark mass parameter, MUR is the third generation
C...right handed stop mass parameter, MDR is the third generation
C...right handed sbottom mass parameter, MTOP is the pole top quark
C...mass; AT,AB are the soft supersymmetry breaking trilinear
C...couplings of the stop and sbottoms, respectively, and MU is the
C...supersymmetric mass parameter
 
C...The parameter IHIGGS=0,1,2,3 corresponds to the
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)
      IMPLICIT INTEGER(I-N)
 
C...Parameters.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      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))
 
C      RXMT = XMT/(1D0+4*ALP3/3D0/PI)
      RXMT = PYRNMT(XMT)
 
      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
      IF(XMUR.LT.0D0) XMUR2=-XMUR2
      XMDR2 = XMDR**2
      XMST11 = RXMT**2 + XMQ2  - 0.35D0*XMZ**2*COS2B
      XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
      IF(XMST11.LT.0D0) GOTO 500
      IF(XMST22.LT.0D0) GOTO 500
      XMSB11 = RMBOT**2 + XMQ2  + 0.42D0*XMZ**2*COS2B
      XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
      IF(XMSB11.LT.0D0) GOTO 500
      IF(XMSB22.LT.0D0) GOTO 500
      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 .OR.ITER.GT.100 ) 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 .OR.ITER.GT.100 ) 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 .OR.ITER.GT.100 ) 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
      WRITE(MSTU(11),*) ' EXITING IN PYVACU '
      WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
      WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
      WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
      STOP
      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)
      IMPLICIT INTEGER(I-N)
C...Parameters.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      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))
 
C      RXMT = XMT/(1D0+4*ALP3/3D0/PI)
      RXMT = PYRNMT(XMT)
 
      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
      IF(XMUR.LT.0D0) XMUR2=-XMUR2
      XMDR2 = XMDR**2
      XMST11 = RXMT**2 + XMQ2  - 0.35D0*XMZ**2*COS2B
      XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
      IF(XMST11.LT.0D0) GOTO 500
      IF(XMST22.LT.0D0) GOTO 500
      XMSB11 = RMBOT**2 + XMQ2  + 0.42D0*XMZ**2*COS2B
      XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
      IF(XMSB11.LT.0D0) GOTO 500
      IF(XMSB22.LT.0D0) GOTO 500
      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
      WRITE(MSTU(11),*) ' EXITING IN PYVACU '
      WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
      WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
      WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
      COMMON/PYHTRI/HHH(7)
 
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
 
C...Defined now in PYSUBH
C      HHH(1)=XLAM1
C      HHH(2)=XLAM2
C      HHH(3)=XLAM3
C      HHH(4)=XLAM4
C      HHH(5)=XLAM5
C      HHH(6)=XLAM6
C      HHH(7)=XLAM7
 
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
      COMMON/PYINTS/XXM(20)
      SAVE/PYINTS/
 
C...Local variables.
      EXTERNAL PYFISB
      DOUBLE PRECISION PYFISB
 
      XXM(1)=A
      XXM(2)=B
      XXM(3)=C
      XLO=0D0
      XHI=1D0
      PYFINT  = PYGAUS(PYFISB,XLO,XHI,1D-3)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYFISB
C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
 
      FUNCTION PYFISB(X)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblock.
      COMMON/PYINTS/XXM(20)
      SAVE/PYINTS/
 
      PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
     &(X*(XXM(2)-XXM(3))+XXM(3)))
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSFDC
C...Calculates decays of sfermions.
 
      SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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(29)
        IDG=39+KSUSY1
        XMGR=PMAS(PYCOMP(IDG),1)
        XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
        IF(IFL.EQ.5) THEN
          XMF=XMBOT
        ELSEIF(IFL.EQ.6) THEN
          XMF=XMTOP
        ELSE
          XMF=PMAS(IFL,1)
        ENDIF
        IF(XMI.GT.XMGR+XMF) THEN
          LKNT=LKNT+1
          IDLAM(LKNT,1)=IDG
          IDLAM(LKNT,2)=IFL
          IDLAM(LKNT,3)=0
          XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
        ENDIF
      ENDIF
 
C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
 
C...CHARGED DECAYS:
      DO 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,3)
          BL=SFMIX(IFL,1)
          AR=-SFMIX(IFL,4)
          BR=SFMIX(IFL,2)
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)
      IMPLICIT INTEGER(I-N)
      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
      EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
      DOUBLE PRECISION 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(29)
        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
C...Minus sign difference from gluino-quark-squark feynman rules
            AL=SFMIX(IFL,1)
            BL=-SFMIX(IFL,3)
            AR=SFMIX(IFL,2)
            BR=-SFMIX(IFL,4)
C...F1 -> F CHI
            IF(ILR.EQ.1) THEN
              CA=AL
              CB=BL
C...F2 -> F CHI
            ELSE
              CA=AR
              CB=BR
            ENDIF
            LKNT=LKNT+1
            XMA2=XMJ**2
            XMB2=XMF**2
            XL=PYLAMF(XMI2,XMA2,XMB2)
            XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
     &      (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
            IDLAM(LKNT,1)=ILR*KSUSY1+IFL
            IDLAM(LKNT,2)=-IFL
            IDLAM(LKNT,3)=0
            LKNT=LKNT+1
            XLAM(LKNT)=XLAM(LKNT-1)
            IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
            IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
            IDLAM(LKNT,3)=0
          ENDIF
  100   CONTINUE
  110 CONTINUE
 
C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
C...GLUINO -> NI Q QBAR
      DO 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...PYTECM
C...Finds the s-hat dependent eigenvalues of the inverse propagator
C...matrix for gamma, Z, technirho, and techniomega to optimize the
C...phase space generation.
 
      SUBROUTINE PYTECM(S1,S2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
 
C...Local variables.
      DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
     &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
     &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:200),WDTE(0:200,0:5)
      INTEGER i,j,ierr

      SH=PMAS(54,1)**2
      AEM=PYALEM(SH)

      TANW=SQRT(PARU(102)/(1D0-PARU(102)))
      CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
      QUPD=2D0*PARP(143)-1D0

      ALPRHT=2.91D0*(3D0/PARP(144))
      FAR=SQRT(AEM/ALPRHT)
      FAO=FAR*QUPD
      FZR=FAR*CT2W
      FZO=-FAO*TANW

      AR(1,1) = SH
      AR(2,2) = SH-PMAS(23,1)**2
      AR(3,3) = SH-PMAS(54,1)**2
      AR(4,4) = SH-PMAS(56,1)**2
      AR(1,2) = 0D0
      AR(2,1) = 0D0
      AR(1,3) = -SH*FAR
      AR(3,1) = AR(1,3)
      AR(1,4) = -SH*FAO
      AR(4,1) = AR(1,4)
      AR(2,3) = -SH*FZR
      AR(3,2) = AR(2,3)
      AR(2,4) = -SH*FZO
      AR(4,2) = AR(2,4)
      AR(3,4) = 0D0
      AR(4,3) = 0D0
CCCCCCCC
      DO 110 I=1,4
        DO 100 J=1,4
          AT(I,J)=0D0
  100   CONTINUE
  110 CONTINUE
      SHR=SQRT(SH)
      CALL PYWIDT(23,SH,WDTP,WDTE)
      AT(2,2) = WDTP(0)*SHR
      CALL PYWIDT(54,SH,WDTP,WDTE)
      AT(3,3) = WDTP(0)*SHR
      CALL PYWIDT(56,SH,WDTP,WDTE)
      AT(4,4) = WDTP(0)*SHR
CCCC
      CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
      DO 120 I=1,4
        WI(I)=SQRT(ABS(SH-WR(I)))
        WR(I)=ABS(WR(I))
  120 CONTINUE
      R1=MIN(WR(1),WR(2),WR(3),WR(4))
      R2=1D20
      S1=0D0
      S2=0D0
      DO 130 I=1,4
        IF(ABS(WR(I)-R1).LT.1D-6) THEN
          S1=WI(I)
          GOTO 130
        ENDIF
        IF(WR(I).LE.R2) THEN
          R2=WR(I)
          S2=WI(I)
        ENDIF
  130 CONTINUE
      S1=S1**2
      S2=S2**2
      RETURN
      END



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

C...PYEIGC
C...Finds eigenvalues of a general complex matrix

      SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
C
      INTEGER N,NM,IS1,IS2,IERR,MATZ
      DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
     X       FV1(N),FV2(N),FV3(N)
C
C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
C     OF A COMPLEX GENERAL MATRIX.
C
C     ON INPUT
C
C        NM  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C        DIMENSION STATEMENT.
C
C        N  IS THE ORDER OF THE MATRIX  A=(AR,AI).
C
C        AR  AND  AI  CONTAIN THE REAL AND IMAGINARY PARTS,
C        RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
C
C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
C        ONLY EIGENVALUES ARE DESIRED.  OTHERWISE IT IS SET TO
C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
C
C     ON OUTPUT
C
C        WR  AND  WI  CONTAIN THE REAL AND IMAGINARY PARTS,
C        RESPECTIVELY, OF THE EIGENVALUES.
C
C        ZR  AND  ZI  CONTAIN THE REAL AND IMAGINARY PARTS,
C        RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
C
C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
C           COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
C           AND COMQR2.  THE NORMAL COMPLETION CODE IS ZERO.
C
C        FV1, FV2, AND  FV3  ARE TEMPORARY STORAGE ARRAYS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  CBAL(NM,N,AR,AI,IS1,IS2,FV1)
      CALL  CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
   50 RETURN
      END
      SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M)
      DOUBLE PRECISION S
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
C     MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
C     BALANCED MATRIX DETERMINED BY  CBAL.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY  CBAL.
C
C        SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
C          AND SCALING FACTORS USED BY  CBAL.
C
C        M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS TO BE
C          BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
C
C     ON OUTPUT
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
C          IN THEIR FIRST M COLUMNS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0D0/SCALE(I). ..........
         DO 100 J = 1, M
            ZR(I,J) = ZR(I,J) * S
            ZI(I,J) = ZI(I,J) * S
  100    CONTINUE
C
  110 CONTINUE
C     .......... FOR I=LOW-1 STEP -1 UNTIL 1,
C                IGH+1 STEP 1 UNTIL N DO -- ..........
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = ZR(I,J)
            ZR(I,J) = ZR(K,J)
            ZR(K,J) = S
            S = ZI(I,J)
            ZI(I,J) = ZI(K,J)
            ZI(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE)
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N)
      DOUBLE PRECISION C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
C     CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
C     NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
C
C     THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
C     EIGENVALUES WHENEVER POSSIBLE.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
C
C     ON OUTPUT
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE BALANCED MATRIX.
C
C        LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
C          ARE EQUAL TO ZERO IF
C           (1) I IS GREATER THAN J AND
C           (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
C
C        SCALE CONTAINS INFORMATION DETERMINING THE
C           PERMUTATIONS AND SCALING FACTORS USED.
C
C     SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
C     HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
C     WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
C     OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J).  THEN
C        SCALE(J) = P(J),    FOR J = 1,...,LOW-1
C                 = D(J,J)       J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
C     THEN 1 TO LOW-1.
C
C     NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
C
C     THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
C     CBAL  IN LINE.  (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
C     K,L HAVE BEEN REVERSED.)
C
C     ARITHMETIC IS REAL THROUGHOUT.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      RADIX = 16.0D0
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     .......... IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE ..........
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = AR(I,J)
         AR(I,J) = AR(I,M)
         AR(I,M) = F
         F = AI(I,J)
         AI(I,J) = AI(I,M)
         AI(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = AR(J,I)
         AR(J,I) = AR(M,I)
         AR(M,I) = F
         F = AI(J,I)
         AI(J,I) = AI(M,I)
         AI(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN ..........
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT ..........
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
      DO 180 I = K, L
  180 SCALE(I) = 1.0D0
C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0D0
         R = 0.0D0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + DABS(AR(J,I)) + DABS(AI(J,I))
            R = R + DABS(AR(I,J)) + DABS(AI(I,J))
  200    CONTINUE
C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
         IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270
         G = R / RADIX
         F = 1.0D0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     .......... NOW BALANCE ..........
  240    IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270
         G = 1.0D0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
            AR(I,J) = AR(I,J) * G
            AI(I,J) = AI(I,J) * G
  250    CONTINUE
C
         DO 260 J = 1, L
            AR(J,I) = AR(J,I) * F
            AI(J,I) = AI(J,I) * F
  260    CONTINUE
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END
      SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI)
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI
C
C     COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
C
      DOUBLE PRECISION S,ARS,AIS,BRS,BIS
      S = DABS(BR) + DABS(BI)
      ARS = AR/S
      AIS = AI/S
      BRS = BR/S
      BIS = BI/S
      S = BRS**2 + BIS**2
      CR = (ARS*BRS + AIS*BIS)/S
      CI = (AIS*BRS - ARS*BIS)/S
      RETURN
      END
      SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
C
      INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
      DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
     X       PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
C     UPPER HESSENBERG MATRIX BY THE QR METHOD.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N.
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
C          INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
C          THE REDUCTION BY  CORTH, IF PERFORMED.
C
C     ON OUTPUT
C
C        THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
C          DESTROYED.  THEREFORE, THEY MUST BE SAVED BEFORE
C          CALLING  COMQR  IF SUBSEQUENT CALCULATION OF
C          EIGENVECTORS IS TO BE PERFORMED.
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C     CALLS CDIV FOR COMPLEX DIVISION.
C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      IERR = 0
      IF (LOW .EQ. IGH) GO TO 180
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
      L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
         NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0D0
C
         DO 155 J = I, IGH
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = LOW, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
  170 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 1001
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
     X            + DABS(HR(L,L)) + DABS(HI(L,L))
         TST2 = TST1 + DABS(HR(L,L-1))
         IF (TST2 .EQ. TST1) GO TO 300
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0D0
      YI = (HI(ENM1,ENM1) - SI) / 2.0D0
      CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.0D0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0D0
         NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0D0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, EN
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0D0) GO TO 540
      NORM = PYTHAG(HR(EN,EN),SI)
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0D0
C     .......... INVERSE OPERATION (COLUMNS) ..........
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = L, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0D0) GO TO 240
C
      DO 630 I = L, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 WR(EN) = HR(EN,EN) + TR
      WI(EN) = HI(EN,EN) + TI
      EN = ENM1
      GO TO 220
C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C                CONVERGED AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
C  MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
C  MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
C
      INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
     X        ITN,ITS,LOW,LP1,ENM1,IEND,IERR
      DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N),
     X       ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
     X       PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
C     ALGOL PROCEDURE  COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
C     AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C     THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
C     (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
C     METHOD.  THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
C     CAN ALSO BE FOUND IF  CORTH  HAS BEEN USED TO REDUCE
C     THIS GENERAL MATRIX TO HESSENBERG FORM.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N.
C
C        ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
C          FORMATIONS USED IN THE REDUCTION BY  CORTH, IF PERFORMED.
C          ONLY ELEMENTS LOW THROUGH IGH ARE USED.  IF THE EIGENVECTORS
C          OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
C          ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
C
C        HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
C          THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
C          INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
C          REDUCTION BY  CORTH, IF PERFORMED.  IF THE EIGENVECTORS OF
C          THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
C          ARBITRARY.
C
C     ON OUTPUT
C
C        ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
C          HAVE BEEN DESTROYED.
C
C        WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVALUES.  IF AN ERROR
C          EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
C          FOR INDICES IERR+1,...,N.
C
C        ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE EIGENVECTORS.  THE EIGENVECTORS
C          ARE UNNORMALIZED.  IF AN ERROR EXIT IS MADE, NONE OF
C          THE EIGENVECTORS HAS BEEN FOUND.
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
C                     WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
C
C     CALLS CDIV FOR COMPLEX DIVISION.
C     CALLS CSROOT FOR COMPLEX SQUARE ROOT.
C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED OCTOBER 1989.
C
C     ------------------------------------------------------------------
C
      IERR = 0
C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 101 J = 1, N
C
         DO 100 I = 1, N
            ZR(I,J) = 0.0D0
            ZI(I,J) = 0.0D0
  100    CONTINUE
         ZR(J,J) = 1.0D0
  101 CONTINUE
C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY CORTH ..........
      IEND = IGH - LOW - 1
      IF (IEND) 180, 150, 105
C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
  105 DO 140 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140
         IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140
C     .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
         NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
         IP1 = I + 1
C
         DO 110 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  110    CONTINUE
C
         DO 130 J = I, IGH
            SR = 0.0D0
            SI = 0.0D0
C
            DO 115 K = I, IGH
               SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
               SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
  115       CONTINUE
C
            SR = SR / NORM
            SI = SI / NORM
C
            DO 120 K = I, IGH
               ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
               ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  150 L = LOW + 1
C
      DO 170 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170
         NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
         YR = HR(I,I-1) / NORM
         YI = HI(I,I-1) / NORM
         HR(I,I-1) = NORM
         HI(I,I-1) = 0.0D0
C
         DO 155 J = I, N
            SI = YR * HI(I,J) - YI * HR(I,J)
            HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
            HI(I,J) = SI
  155    CONTINUE
C
         DO 160 J = 1, LL
            SI = YR * HI(J,I) + YI * HR(J,I)
            HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
            HI(J,I) = SI
  160    CONTINUE
C
         DO 165 J = LOW, IGH
            SI = YR * ZI(J,I) + YI * ZR(J,I)
            ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
            ZI(J,I) = SI
  165    CONTINUE
C
  170 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  180 DO 200 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  200 CONTINUE
C
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  220 IF (EN .LT. LOW) GO TO 680
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  240 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GO TO 300
         TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
     X            + DABS(HR(L,L)) + DABS(HI(L,L))
         TST2 = TST1 + DABS(HR(L,L-1))
         IF (TST2 .EQ. TST1) GO TO 300
  260 CONTINUE
C     .......... FORM SHIFT ..........
  300 IF (L .EQ. EN) GO TO 660
      IF (ITN .EQ. 0) GO TO 1000
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320
      SR = HR(EN,EN)
      SI = HI(EN,EN)
      XR = HR(ENM1,EN) * HR(EN,ENM1)
      XI = HI(ENM1,EN) * HR(EN,ENM1)
      IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340
      YR = (HR(ENM1,ENM1) - SR) / 2.0D0
      YI = (HI(ENM1,ENM1) - SI) / 2.0D0
      CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310
      ZZR = -ZZR
      ZZI = -ZZI
  310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GO TO 340
C     .......... FORM EXCEPTIONAL SHIFT ..........
  320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.0D0
C
  340 DO 360 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  360 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 500 I = LP1, EN
         SR = HR(I,I-1)
         HR(I,I-1) = 0.0D0
         NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
         XR = HR(I-1,I-1) / NORM
         WR(I-1) = XR
         XI = HI(I-1,I-1) / NORM
         WI(I-1) = XI
         HR(I-1,I-1) = NORM
         HI(I-1,I-1) = 0.0D0
         HI(I,I-1) = SR / NORM
C
         DO 490 J = I, N
            YR = HR(I-1,J)
            YI = HI(I-1,J)
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
            HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
            HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
            HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
  490    CONTINUE
C
  500 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0D0) GO TO 540
      NORM = PYTHAG(HR(EN,EN),SI)
      SR = HR(EN,EN) / NORM
      SI = SI / NORM
      HR(EN,EN) = NORM
      HI(EN,EN) = 0.0D0
      IF (EN .EQ. N) GO TO 540
      IP1 = EN + 1
C
      DO 520 J = IP1, N
         YR = HR(EN,J)
         YI = HI(EN,J)
         HR(EN,J) = SR * YR + SI * YI
         HI(EN,J) = SR * YI - SI * YR
  520 CONTINUE
C     .......... INVERSE OPERATION (COLUMNS) ..........
  540 DO 600 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 580 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GO TO 560
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  560       HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  580    CONTINUE
C
         DO 590 I = LOW, IGH
            YR = ZR(I,J-1)
            YI = ZI(I,J-1)
            ZZR = ZR(I,J)
            ZZI = ZI(I,J)
            ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
            ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
            ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
            ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
  590    CONTINUE
C
  600 CONTINUE
C
      IF (SI .EQ. 0.0D0) GO TO 240
C
      DO 630 I = 1, EN
         YR = HR(I,EN)
         YI = HI(I,EN)
         HR(I,EN) = SR * YR - SI * YI
         HI(I,EN) = SR * YI + SI * YR
  630 CONTINUE
C
      DO 640 I = LOW, IGH
         YR = ZR(I,EN)
         YI = ZI(I,EN)
         ZR(I,EN) = SR * YR - SI * YI
         ZI(I,EN) = SR * YI + SI * YR
  640 CONTINUE
C
      GO TO 240
C     .......... A ROOT FOUND ..........
  660 HR(EN,EN) = HR(EN,EN) + TR
      WR(EN) = HR(EN,EN)
      HI(EN,EN) = HI(EN,EN) + TI
      WI(EN) = HI(EN,EN)
      EN = ENM1
      GO TO 220
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  680 NORM = 0.0D0
C
      DO 720 I = 1, N
C
         DO 720 J = I, N
            TR = DABS(HR(I,J)) + DABS(HI(I,J))
            IF (TR .GT. NORM) NORM = TR
  720 CONTINUE
C
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001
C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
      DO 800 NN = 2, N
         EN = N + 2 - NN
         XR = WR(EN)
         XI = WI(EN)
         HR(EN,EN) = 1.0D0
         HI(EN,EN) = 0.0D0
         ENM1 = EN - 1
C     .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
         DO 780 II = 1, ENM1
            I = EN - II
            ZZR = 0.0D0
            ZZI = 0.0D0
            IP1 = I + 1
C
            DO 740 J = IP1, EN
               ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
               ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
  740       CONTINUE
C
            YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765
               TST1 = NORM
               YR = TST1
  760          YR = 0.01D0 * YR
               TST2 = NORM + YR
               IF (TST2 .GT. TST1) GO TO 760
  765       CONTINUE
            CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
C     .......... OVERFLOW CONTROL ..........
            TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
            IF (TR .EQ. 0.0D0) GO TO 780
            TST1 = TR
            TST2 = TST1 + 1.0D0/TST1
            IF (TST2 .GT. TST1) GO TO 780
            DO 770 J = I, EN
               HR(J,EN) = HR(J,EN)/TR
               HI(J,EN) = HI(J,EN)/TR
  770       CONTINUE
C
  780    CONTINUE
C
  800 CONTINUE
C     .......... END BACKSUBSTITUTION ..........
C     .......... VECTORS OF ISOLATED ROOTS ..........
      DO  840 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840
C
         DO 820 J = I, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  820    CONTINUE
C
  840 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
      DO 880 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 880 I = LOW, IGH
            ZZR = 0.0D0
            ZZI = 0.0D0
C
            DO 860 K = LOW, M
               ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
               ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
  860       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  880 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C                CONVERGED AFTER 30*N ITERATIONS ..........
 1000 IERR = EN
 1001 RETURN
      END
      SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH)
      DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
C
C     THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
C     THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
C     BY MARTIN AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
C     REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
C     LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
C     UNITARY SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT.
C
C        N IS THE ORDER OF THE MATRIX.
C
C        LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
C          SUBROUTINE  CBAL.  IF  CBAL  HAS NOT BEEN USED,
C          SET LOW=1, IGH=N.
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
C
C     ON OUTPUT
C
C        AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
C          RESPECTIVELY, OF THE HESSENBERG MATRIX.  INFORMATION
C          ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
C          IS STORED IN THE REMAINING TRIANGLES UNDER THE
C          HESSENBERG MATRIX.
C
C        ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
C          TRANSFORMATIONS.  ONLY ELEMENTS LOW THROUGH IGH ARE USED.
C
C     CALLS PYTHAG FOR  DSQRT(A*A + B*B) .
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C     MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C     THIS VERSION DATED AUGUST 1983.
C
C     ------------------------------------------------------------------
C
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0D0
         ORTR(M) = 0.0D0
         ORTI(M) = 0.0D0
         SCALE = 0.0D0
C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
         DO 90 I = M, IGH
   90    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
C
         IF (SCALE .EQ. 0.0D0) GO TO 180
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 100 II = M, IGH
            I = MP - II
            ORTR(I) = AR(I,M-1) / SCALE
            ORTI(I) = AI(I,M-1) / SCALE
            H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  100    CONTINUE
C
         G = DSQRT(H)
         F = PYTHAG(ORTR(M),ORTI(M))
         IF (F .EQ. 0.0D0) GO TO 103
         H = H + F * G
         G = G / F
         ORTR(M) = (1.0D0 + G) * ORTR(M)
         ORTI(M) = (1.0D0 + G) * ORTI(M)
         GO TO 105
C
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
C     .......... FORM (I-(U*UT)/H) * A ..........
  105    DO 130 J = M, N
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 110 II = M, IGH
               I = MP - II
               FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
               FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  110       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 120 I = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
               AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  120       CONTINUE
C
  130    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 JJ = M, IGH
               J = MP - JJ
               FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
               FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  140       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 150 J = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
               AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  150       CONTINUE
C
  160    CONTINUE
C
         ORTR(M) = SCALE * ORTR(M)
         ORTI(M) = SCALE * ORTI(M)
         AR(M,M-1) = -G * AR(M,M-1)
         AI(M,M-1) = -G * AI(M,M-1)
  180 CONTINUE
C
  200 RETURN
      END
      SUBROUTINE CSROOT(XR,XI,YR,YI)
      DOUBLE PRECISION XR,XI,YR,YI
C
C     (YR,YI) = COMPLEX DSQRT(XR,XI) 
C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C
      DOUBLE PRECISION S,TR,TI,PYTHAG
      TR = XR
      TI = XI
      S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
      IF (TR .GE. 0.0D0) YR = S
      IF (TI .LT. 0.0D0) S = -S
      IF (TR .LE. 0.0D0) YI = S
      IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
      IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
      RETURN
      END
      DOUBLE PRECISION FUNCTION PYTHAG(A,B)
      DOUBLE PRECISION A,B
C
C     FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
      DOUBLE PRECISION P,R,S,T,U
      P = DMAX1(DABS(A),DABS(B))
      IF (P .EQ. 0.0D0) GO TO 20
      R = (DMIN1(DABS(A),DABS(B))/P)**2
   10 CONTINUE
         T = 4.0D0 + R
         IF (T .EQ. 4.0D0) GO TO 20
         S = R/T
         U = 1.0D0 + 2.0D0*S
         P = U*P
         R = (S/U)**2 * R
      GO TO 10
   20 PYTHAG = P
      RETURN
      END
 
C*********************************************************************
 
C...PYTBBN
C...Calculates the three-body decay of gluinos into
C...neutralinos and third generation fermions.
 
      SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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
      DOUBLE PRECISION PYSIMP,PYLAMF
      INTEGER LIN,NN
      DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
      DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
      DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
      DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
      DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
      DOUBLE PRECISION XLN1,XLN2,B1,B2
      DOUBLE PRECISION E,XMGLU,GAM
      DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
      SAVE HRB,HLB,FLB,FRB
      DOUBLE PRECISION ALPHAW,ALPHAS,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)
      IMPLICIT INTEGER(I-N)
      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
      DOUBLE PRECISION PYSIMP,PYLAMF
      INTEGER I,NN,LIN
      DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
      DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
      DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
      DOUBLE PRECISION SUMME(0:100),A(4,8)
      DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
      DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
      DOUBLE PRECISION XMGLU,GAM
      DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
     &DDD(2),EEE(2),FFF(2)
      SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
      DOUBLE PRECISION ALPHAW,ALPHAS,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)
      IMPLICIT INTEGER(I-N)
      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 PYXXGA
      EXTERNAL PYXXW5,PYGAUS,PYXXZ5
      DOUBLE PRECISION 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) GOTO 260
 
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 300
      ENDIF
 
C...GRAVITINO DECAY MODES
 
      IF(IMSS(11).EQ.1) THEN
        XMP=RMSS(29)
        IDG=39+KSUSY1
        XMGR=PMAS(PYCOMP(IDG),1)
        SINW=SQRT(XW)
        COSW=SQRT(1D0-XW)
        XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
        IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
          LKNT=LKNT+1
          IDLAM(LKNT,1)=IDG
          IDLAM(LKNT,2)=22
          IDLAM(LKNT,3)=0
          XLAM(LKNT)=XFAC*(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
        IF(IX.EQ.1) GOTO 260
      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
  260 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 270
        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
  270   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 280
        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
  280   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 290
        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
  290   CONTINUE
      ENDIF
 
  300 IKNT=LKNT
      XLAM(0)=0D0
      DO 310 I=1,IKNT
        IF(XLAM(I).LT.0D0) XLAM(I)=0D0
        XLAM(0)=XLAM(0)+XLAM(I)
  310 CONTINUE
      IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
 
      RETURN
      END
 
C*********************************************************************
 
C...PYCJDC
C...Calculate decay widths for the charginos (admixtures of
C...charged Wino and charged Higgsino.
 
C...Input:  KCIN = KF code for particle
C...Output: XLAM = widths
C...        IDLAM = KF codes for decay particles
C...        IKNT = number of decay channels defined
C...AUTHOR: STEPHEN MRENNA
C...Last change:
C...10-16-95:  force decay chi^+_1 -> chi^0_1 e+ nu_e
C...when CHIENU .NE. 0
 
      SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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
      EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2
      DOUBLE PRECISION 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(29)
        IDG=39+KSUSY1
        XMGR=PMAS(PYCOMP(IDG),1)
        SINW=SQRT(XW)
        COSW=SQRT(1D0-XW)
        XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
        IF(AXMI.GT.XMGR+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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local variables.
      DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
      DOUBLE PRECISION F1,F2
 
      F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
      F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
      PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
      PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
 
      RETURN
      END
 
C*********************************************************************
 
C...PYX2XG
C...Calculates the decay rate for ino -> ino + gauge boson.
 
      FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local variables.
      DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Local variables.
      DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
      DOUBLE PRECISION XL,PYLAMF,C1
      DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
 
      XMI2=XM1**2
      XMI3=ABS(XM1**3)
      XMJ2=XM2**2
      XMK2=XM3**2
      XL=PYLAMF(XMI2,XMJ2,XMK2)
      PYH2XX=C1/4D0/XMI3*SQRT(XL)
     &*((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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local declarations.
      EXTERNAL F
      DOUBLE PRECISION F,W(12), X(12)
      DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
      DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
      DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
      DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
      DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
      DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
      DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
      DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
      DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
      DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
      DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
      DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
 
C...The Gaussian quadrature algorithm.
      H = 0D0
      IF(B .EQ. A) 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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local variables.
      DOUBLE PRECISION Y,X0,X1,H,S
      DIMENSION Y(0:N)
 
      S=0D0
      H=(X1-X0)/N
      DO 100 I=0,N-2,2
        S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
  100 CONTINUE
      PYSIMP=S*H/3D0
 
      RETURN
      END
 
C*********************************************************************
 
C...PYLAMF
C...The standard lambda function.
 
      FUNCTION PYLAMF(X,Y,Z)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Local variables.
      DOUBLE PRECISION PYLAMF,X,Y,Z
 
      PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
      IF(PYLAMF.LT.0D0) PYLAMF=0D0
 
      RETURN
      END
 
C*********************************************************************
 
C...PYTBDY
C...Generates 3-body decays of gauginos.
 
      SUBROUTINE PYTBDY(XM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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...PY2FRM
C...An interface from a two-fermion generator to include
C...parton showers and hadronization.
 
      SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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 IJOIN(2),INTAU(2)
 
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF
 
C...Loop through entries and pick up all final fermions/antifermions.
      I1=0
      I2=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=IABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
        IF(K(I,2).GT.0) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSE
            CALL PYERRM(16,'(PY2FRM:) more than one fermion')
          ENDIF
        ELSE
          IF(I2.EQ.0) THEN
            I2=I
          ELSE
            CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
 
C...Check that event is arranged according to conventions.
      IF(I1.EQ.0.OR.I2.EQ.0) THEN
        CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
      ENDIF
      IF(I2.LT.I1) THEN
        CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
      ENDIF
 
C...Check whether fermion pair is quarks or leptons.
      IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
        IQL12=1
      ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
        IQL12=2
      ELSE
        CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
      ENDIF
 
C...Decide whether to allow or not photon radiation in showers.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1
 
C...Do colour joining and parton showers.
      IP1=I1
      IP2=I2 
      IF(IQL12.EQ.1) THEN 
        IJOIN(1)=IP1
        IJOIN(2)=IP2
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
        PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
     &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
        CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
      ENDIF
 
C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 110 I=1,N
        IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
          NTAU=NTAU+1
          INTAU(NTAU)=I
          K(I,1)=11
        ENDIF
  110   CONTINUE
      ENDIF       
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 120 I=1,NTAU
        K(INTAU(I),1)=1
  120   CONTINUE
      ENDIF       
 
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF
 
      END
 
C*********************************************************************
 
C...PY4FRM
C...An interface from a four-fermion generator to include
C...parton showers and hadronization.
 
      SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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 IJOIN(2),INTAU(4)
 
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF
 
C...Loop through entries and pick up all final fermions/antifermions.
      I1=0
      I2=0
      I3=0
      I4=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=IABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
        IF(K(I,2).GT.0) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSEIF(I3.EQ.0) THEN
            I3=I
          ELSE
            CALL PYERRM(16,'(PY4FRM:) more than two fermions')
          ENDIF
        ELSE
          IF(I2.EQ.0) THEN
            I2=I
          ELSEIF(I4.EQ.0) THEN
            I4=I
          ELSE
            CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
 
C...Check that event is arranged according to conventions.
      IF(I3.EQ.0.OR.I4.EQ.0) THEN
        CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
      ENDIF
      IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
        CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
      ENDIF
 
C...Check which fermion pairs are quarks and which leptons.
      IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
        IQL12=1
      ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
        IQL12=2
      ELSE
        CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
      ENDIF
      IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
        IQL34=1
      ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
        IQL34=2
      ELSE
        CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
      ENDIF
 
C...Decide whether to allow or not photon radiation in showers.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1
 
C...Decide on dipole pairing.
      IP1=I1
      IP2=I2
      IP3=I3
      IP4=I4
      IF(IQL12.EQ.IQL34) THEN
        R1SQ=A1SQ
        R2SQ=A2SQ
        DELTA=ATOTSQ-A1SQ-A2SQ
        IF(ISTRAT.EQ.1) THEN
          IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
          IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
        ELSEIF(ISTRAT.EQ.2) THEN
          IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
          IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
        ENDIF
        IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
          IP2=I4
          IP4=I2
        ENDIF
      ENDIF
 
C...Do colour joinings and parton showers.
      IF(IQL12.EQ.1) THEN 
        IJOIN(1)=IP1
        IJOIN(2)=IP2
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
        PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
     &  (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
        CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
      ENDIF
      IF(IQL34.EQ.1) THEN
        IJOIN(1)=IP3
        IJOIN(2)=IP4
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN        
        PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
     &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
        CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
      ENDIF
 
C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 110 I=1,N
        IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
          NTAU=NTAU+1
          INTAU(NTAU)=I
          K(I,1)=11
        ENDIF
  110   CONTINUE
      ENDIF       
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 120 I=1,NTAU
        K(INTAU(I),1)=1
  120   CONTINUE
      ENDIF       
 
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF
 
      END
  
C*********************************************************************
 
C...PY6FRM
C...An interface from a six-fermion generator to include
C...parton showers and hadronization.
 
      SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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 IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
 
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF
 
C...Loop through entries and pick up all final fermions/antifermions.
      I1=0
      I2=0
      I3=0
      I4=0
      I5=0
      I6=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=IABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
        IF(K(I,2).GT.0) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSEIF(I3.EQ.0) THEN
            I3=I
          ELSEIF(I5.EQ.0) THEN
            I5=I
          ELSE
            CALL PYERRM(16,'(PY6FRM:) more than three fermions')
          ENDIF
        ELSE
          IF(I2.EQ.0) THEN
            I2=I
          ELSEIF(I4.EQ.0) THEN
            I4=I
          ELSEIF(I6.EQ.0) THEN
            I6=I
          ELSE
            CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
 
C...Check that event is arranged according to conventions.
      IF(I5.EQ.0.OR.I6.EQ.0) THEN
        CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
      ENDIF
      IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
        CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
      ENDIF
 
C...Check which fermion pairs are quarks and which leptons.
      IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
        IQL12=1
      ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
        IQL12=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
      ENDIF
      IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
        IQL34=1
      ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
        IQL34=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
      ENDIF
      IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
        IQL56=1
      ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
        IQL56=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
      ENDIF
 
C...Decide whether to allow or not photon radiation in showers.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1
 
C...Allow dipole pairings only among leptons and quarks separately.
      P12D=P12
      P13D=0D0
      IF(IQL34.EQ.IQL56) P13D=P13
      P21D=0D0
      IF(IQL12.EQ.IQL34) P21D=P21
      P23D=0D0
      IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
      P31D=0D0
      IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
      P32D=0D0
      IF(IQL12.EQ.IQL56) P32D=P32
 
C...Decide whether t+tbar.
      ITOP=0
      IF(PYR(0).LT.PTOP) THEN
        ITOP=1
 
C...If t+tbar: reconstruct t's.
        IT=N+1
        ITB=N+2
        DO 110 J=1,5
          K(IT,J)=0
          K(ITB,J)=0
          P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
          P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
          V(IT,J)=0D0
          V(ITB,J)=0D0
  110   CONTINUE
        K(IT,1)=1
        K(ITB,1)=1
        K(IT,2)=6
        K(ITB,2)=-6
        P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
     &  P(IT,3)**2))
        P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
     &  P(ITB,3)**2))
        N=N+2
 
C...If t+tbar: colour join t's and let them shower.
        IJOIN(1)=IT
        IJOIN(2)=ITB
        CALL PYJOIN(2,IJOIN)
        PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
     &  (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
        CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
 
C...If t+tbar: pick up the t's after shower.
        ITNEW=IT
        ITBNEW=ITB
        DO 120 I=ITB+1,N
          IF(K(I,2).EQ.6) ITNEW=I
          IF(K(I,2).EQ.-6) ITBNEW=I
  120   CONTINUE
 
C...If t+tbar: loop over two top systems.
        DO 200 IT1=1,2
          IF(IT1.EQ.1) THEN
            ITO=IT
            ITN=ITNEW
            IBO=I1
            IW1=I3
            IW2=I4
          ELSE
            ITO=ITB
            ITN=ITBNEW
            IBO=I2
            IW1=I5
            IW2=I6
          ENDIF
          IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
     &    '(PY6FRM:) not b in t decay')
 
C...If t+tbar: find boost from original to new top frame.
          DO 130 J=1,3
            BETAO(J)=P(ITO,J)/P(ITO,4)
            BETAN(J)=P(ITN,J)/P(ITN,4)
  130     CONTINUE
 
C...If t+tbar: boost copy of b by t shower and connect it in colour.
          N=N+1
          IB=N
          K(IB,1)=3
          K(IB,2)=K(IBO,2)
          K(IB,3)=ITN
          DO 140 J=1,5
            P(IB,J)=P(IBO,J)
            V(IB,J)=0D0
  140     CONTINUE
          CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
          K(IB,4)=MSTU(5)*ITN
          K(IB,5)=MSTU(5)*ITN
          K(ITN,4)=K(ITN,4)+IB
          K(ITN,5)=K(ITN,5)+IB
          K(ITN,1)=K(ITN,1)+10
          K(IBO,1)=K(IBO,1)+10
 
C...If t+tbar: construct W recoiling against b.
          N=N+1
          IW=N
          DO 150 J=1,5
            K(IW,J)=0
            V(IW,J)=0D0
  150     CONTINUE
          K(IW,1)=1
          KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
          IF(IABS(KCHW).EQ.3) THEN
            K(IW,2)=ISIGN(24,KCHW)
          ELSE
            CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
          ENDIF
          K(IW,3)=IW1
 
C...If t+tbar: construct W momentum, including boost by t shower.
          DO 160 J=1,4
            P(IW,J)=P(IW1,J)+P(IW2,J)
  160     CONTINUE
          P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
     &    P(IW,3)**2))
          CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
 
C...If t+tbar: boost b and W to top rest frame.
          DO 170 J=1,3
            BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
  170     CONTINUE
          CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
          CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
 
C...If t+tbar: let b shower and pick up modified W.
          PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
     &    (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
          CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
          DO 180 I=IW,N
            IF(IABS(K(I,2)).EQ.24) IWM=I
  180     CONTINUE
 
C...If t+tbar: take copy of W decay products.
          DO 190 J=1,5
            K(N+1,J)=K(IW1,J)
            P(N+1,J)=P(IW1,J)
            V(N+1,J)=V(IW1,J)
            K(N+2,J)=K(IW2,J)
            P(N+2,J)=P(IW2,J)
            V(N+2,J)=V(IW2,J)
  190     CONTINUE
          K(IW1,1)=K(IW1,1)+10
          K(IW2,1)=K(IW2,1)+10
          K(IWM,1)=K(IWM,1)+10
          K(IWM,4)=N+1
          K(IWM,5)=N+2
          K(N+1,3)=IWM
          K(N+2,3)=IWM
          IF(IT1.EQ.1) THEN
            I3=N+1
            I4=N+2
          ELSE
            I5=N+1
            I6=N+2
          ENDIF
          N=N+2
 
C...If t+tbar: boost W decay products, first by effects of t shower,
C...then by those of b shower. b and its shower simple boost back.
          CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
          CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
          CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
     &    -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
          CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
     &    P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
          CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
          CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
  200   CONTINUE
      ENDIF
 
C...Decide on dipole pairing.
      IP1=I1
      IP3=I3
      IP5=I5
      PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
      IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
        IP2=I2
        IP4=I4
        IP6=I6
      ELSEIF(PRN.LT.P12D+P13D) THEN
        IP2=I2
        IP4=I6
        IP6=I4
      ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
        IP2=I4
        IP4=I2
        IP6=I6
      ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
        IP2=I4
        IP4=I6
        IP6=I2
      ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
        IP2=I6
        IP4=I2
        IP6=I4
      ELSE
        IP2=I6
        IP4=I4
        IP6=I2
      ENDIF
 
C...Do colour joinings and parton showers
C...(except ones already made for t+tbar).
      IF(ITOP.EQ.0) THEN
        IF(IQL12.EQ.1) THEN
          IJOIN(1)=IP1
          IJOIN(2)=IP2
          CALL PYJOIN(2,IJOIN)
        ENDIF
        IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
          PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
     &    (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
          CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
        ENDIF
      ENDIF
      IF(IQL34.EQ.1) THEN
        IJOIN(1)=IP3
        IJOIN(2)=IP4
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
        PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
     &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
        CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
      ENDIF
      IF(IQL56.EQ.1) THEN
        IJOIN(1)=IP5
        IJOIN(2)=IP6
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
        PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
     &  (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
        CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
      ENDIF
 
C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 210 I=1,N
        IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
          NTAU=NTAU+1
          INTAU(NTAU)=I
          K(I,1)=11
        ENDIF
  210   CONTINUE
      ENDIF
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 220 I=1,NTAU
        K(INTAU(I),1)=1
  220   CONTINUE
      ENDIF
 
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF
 
      END
  
C*********************************************************************

C...PY4JET
C...An interface from a four-parton generator to include
C...parton showers and hadronization.
 
      SUBROUTINE PY4JET(PMAX,IRAD,ICOM)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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 IJOIN(2),PTOT(4),BETA(3)
 
C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF
 
C...Loop through entries and pick up all final partons.
      I1=0
      I2=0
      I3=0
      I4=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=IABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
        IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSEIF(I3.EQ.0) THEN
            I3=I
          ELSE
            CALL PYERRM(16,'(PY4JET:) more than two quarks')
          ENDIF
        ELSEIF(K(I,2).LT.0) THEN
          IF(I2.EQ.0) THEN
            I2=I
          ELSEIF(I4.EQ.0) THEN
            I4=I
          ELSE
            CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
          ENDIF
        ELSE
          IF(I3.EQ.0) THEN
            I3=I
          ELSEIF(I4.EQ.0) THEN
            I4=I
          ELSE
            CALL PYERRM(16,'(PY4JET:) more than two gluons')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE
 
C...Check that event is arranged according to conventions.
      IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
        CALL PYERRM(16,'(PY4JET:) event contains too few partons')
      ENDIF
      IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
        CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
      ENDIF
 
C...Check whether second pair are quarks or gluons.
      IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
        IQG34=1
      ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
        IQG34=2
      ELSE
        CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
      ENDIF

C...Boost partons to their cm frame.
      DO 110 J=1,4
        PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
  110 CONTINUE
      ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
      DO 120 J=1,3
        BETA(J)=PTOT(J)/PTOT(4)
  120 CONTINUE
      CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
      CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
      CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
      CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
      NSAV=N
 
C...Decide and set up shower history for q qbar q' qbar' events.
      IF(IQG34.EQ.1) THEN
        W1=PY4JTW(0,I1,I3,I4)        
        W2=PY4JTW(0,I2,I3,I4)
        IF(W1.GT.PYR(0)*(W1+W2)) THEN
          CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
        ELSE
          CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
        ENDIF

C...Decide and set up shower history for q qbar g g events.
      ELSE
        W1=PY4JTW(I1,I3,I2,I4)        
        W2=PY4JTW(I1,I4,I2,I3)
        W3=PY4JTW(0,I3,I1,I4)        
        W4=PY4JTW(0,I4,I1,I3)        
        W5=PY4JTW(0,I3,I2,I4)        
        W6=PY4JTW(0,I4,I2,I3)        
        W7=PY4JTW(0,I1,I3,I4)        
        W8=PY4JTW(0,I2,I3,I4)
        WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
        IF(W1.GT.WR) THEN
          CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
        ELSEIF(W1+W2.GT.WR) THEN
          CALL PY4JTS(I1,I4,I2,I3,0,QMAX) 
        ELSEIF(W1+W2+W3.GT.WR) THEN
          CALL PY4JTS(0,I3,I1,I4,I2,QMAX) 
        ELSEIF(W1+W2+W3+W4.GT.WR) THEN
          CALL PY4JTS(0,I4,I1,I3,I2,QMAX) 
        ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
          CALL PY4JTS(0,I3,I2,I4,I1,QMAX) 
        ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
          CALL PY4JTS(0,I4,I2,I3,I1,QMAX) 
        ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
          CALL PY4JTS(0,I1,I3,I4,I2,QMAX) 
        ELSE
          CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
        ENDIF
      ENDIF 

C...Boost back original partons and mark them as deleted.
      CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
      CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
      CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
      CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
      K(I1,1)=K(I1,1)+10 
      K(I2,1)=K(I2,1)+10 
      K(I3,1)=K(I3,1)+10 
      K(I4,1)=K(I4,1)+10 

C...Rotate shower initiating partons to be along z axis.
      PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) 
      CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
      THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) 
      CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)

C...Set up copy of shower initiating partons as on mass shell.
      DO 140 I=N+1,N+2
        DO 130 J=1,5
          K(I,J)=0
          P(I,J)=0D0
          V(I,J)=V(I1,J) 
  130   CONTINUE 
        K(I,1)=1
        K(I,2)=K(I-6,2)  
  140 CONTINUE   
      IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
        K(N+1,3)=I1
        P(N+1,5)=P(I1,5)
        K(N+2,3)=I2
        P(N+2,5)=P(I2,5)
      ELSE
        K(N+1,3)=I2
        P(N+1,5)=P(I2,5)
        K(N+2,3)=I1
        P(N+2,5)=P(I1,5)
      ENDIF
      PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
     &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
      P(N+1,3)=PABS
      P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
      P(N+2,3)=-PABS
      P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
      N=N+2
  
C...Decide whether to allow or not photon radiation in showers.
C...Connect up colours.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1
      IJOIN(1)=N-1
      IJOIN(2)=N
      CALL PYJOIN(2,IJOIN)

C...Decide on maximum virtuality and do parton shower.
      IF(PMAX.LT.PARJ(82)) THEN
        PQMAX=QMAX
      ELSE
        PQMAX=PMAX
      ENDIF  
      CALL PYSHOW(NSAV+1,-8,PQMAX)

C...Rotate and boost back system.
      CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
 
C...Do fragmentation and decays. 
      CALL PYEXEC
 
C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN 
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PY4JTW
C...Auxiliary to PY4JET, to evaluate weight of configuration.
 
      FUNCTION PY4JTW(IA1,IA2,IA3,IA4)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      SAVE /PYJETS/

C...First case: when both original partons radiate.
C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
      IF(IA1.NE.0) THEN
        DO 100 J=1,4
          P(N+1,J)=P(IA1,J)+P(IA2,J)
          P(N+2,J)=P(IA3,J)+P(IA4,J)
  100   CONTINUE   
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
     &  P(N+2,3)**2))
        Z1=P(IA1,4)/P(N+1,4) 
        WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
        Z2=P(IA3,4)/P(N+2,4)
        WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)

C...Second case: when one original parton radiates to three.
C...IA1  = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
      ELSE
        DO 110 J=1,4
          P(N+2,J)=P(IA3,J)+P(IA4,J)
          P(N+1,J)=P(N+2,J)+P(IA2,J)
  110   CONTINUE   
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
     &  P(N+2,3)**2))
        IF(K(IA2,2).EQ.21) THEN
          Z1=P(N+2,4)/P(N+1,4)
          WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
     &    P(IA3,5)**2)
        ELSE
          Z1=P(IA2,4)/P(N+1,4)
          WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
     &    P(IA2,5)**2)
        ENDIF           
        Z2=P(IA3,4)/P(N+2,4)
        IF(K(IA2,2).EQ.21) THEN
          WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
     &    P(IA3,5)**2)
        ELSEIF(K(IA3,2).EQ.21) THEN
          WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
        ELSE
          WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
        ENDIF 
      ENDIF 
 
C...Total weight.
      PY4JTW=WT1*WT2

      RETURN
      END 
 
C*********************************************************************
 
C...PY4JTS
C...Auxiliary to PY4JET, to set up chosen configuration.
 
      SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      SAVE /PYJETS/

C...Reset info.
      DO 110 I=N+1,N+6
        DO 100 J=1,5
          K(I,J)=0
          V(I,J)=V(IA2,J) 
  100   CONTINUE
        K(I,1)=16   
  110 CONTINUE   
          
C...First case: when both original partons radiate.
C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
      IF(IA1.NE.0) THEN

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA1,2)
        K(N+2,2)=K(IA3,2)
        K(N+3,2)=K(IA1,2)
        K(N+4,2)=K(IA2,2)
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA1
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA3
        K(N+2,4)=N+5
        K(N+2,5)=N+6
        K(N+3,3)=N+1
        K(N+4,3)=N+1
        K(N+5,3)=N+2
        K(N+6,3)=N+2

C...Set up momenta for new partons.
        DO 120 J=1,5
          P(N+1,J)=P(IA1,J)+P(IA2,J)
          P(N+2,J)=P(IA3,J)+P(IA4,J)
          P(N+3,J)=P(IA1,J)
          P(N+4,J)=P(IA2,J) 
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J) 
  120   CONTINUE   
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
     &  P(N+2,3)**2))
        QMAX=MIN(P(N+1,5),P(N+2,5))
          
C...Second case: q radiates twice.
C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
      ELSEIF(K(IA2,2).EQ.21) THEN

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA3,2)
        K(N+2,2)=K(IA5,2)
        K(N+3,2)=K(IA3,2)
        K(N+4,2)=K(IA2,2)
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA3
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA5
        K(N+3,3)=N+1
        K(N+3,4)=N+5
        K(N+3,5)=N+6
        K(N+4,3)=N+1
        K(N+5,3)=N+3
        K(N+6,3)=N+3

C...Set up momenta for new partons.
        DO 130 J=1,5
          P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
          P(N+2,J)=P(IA5,J)
          P(N+3,J)=P(IA3,J)+P(IA4,J)
          P(N+4,J)=P(IA2,J) 
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J) 
  130   CONTINUE   
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
     &  P(N+3,3)**2))
        QMAX=P(N+3,5)
          
C...Third case: q radiates g, g branches.
C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
C...IA5=N+2 does not radiate.
      ELSE

C...Set up flavour and history pointers for new partons.
        K(N+1,2)=K(IA2,2) 
        K(N+2,2)=K(IA5,2)
        K(N+3,2)=K(IA2,2) 
        K(N+4,2)=21 
        K(N+5,2)=K(IA3,2)
        K(N+6,2)=K(IA4,2)
        K(N+1,3)=IA2 
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,3)=IA5
        K(N+3,3)=N+1
        K(N+4,3)=N+1 
        K(N+4,4)=N+5
        K(N+4,5)=N+6
        K(N+5,3)=N+4  
        K(N+6,3)=N+4  

C...Set up momenta for new partons.
        DO 140 J=1,5
          P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
          P(N+2,J)=P(IA5,J)
          P(N+3,J)=P(IA2,J) 
          P(N+4,J)=P(IA3,J)+P(IA4,J) 
          P(N+5,J)=P(IA3,J)
          P(N+6,J)=P(IA4,J) 
  140   CONTINUE  
        P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
     &  P(N+1,3)**2))
        P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
     &  P(N+4,3)**2))
        QMAX=P(N+4,5)

      ENDIF 
      N=N+6

      RETURN
      END
  
C*********************************************************************
 
C...PYJOIN
C...Connects a sequence of partons with colour flow indices,
C...as required for subsequent shower evolution (or other operations).
 
      SUBROUTINE PYJOIN(NJOIN,IJOIN)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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. 
C...Allows small systems to collapse into one or two particles. 
C...Checks flavours and colour singlet invarient masses.
 
      SUBROUTINE PYPREP(IP)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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),PG(5),
     &E1(3),E2(3),E3(3),E4(3),ECL(3)
 
C...Function to give four-product.
      FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
 
C...Rearrange parton shower product listing along strings: begin loop.
      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
 
C...Done if no checks on small-mass systems.
      IF(MSTJ(14).LT.0) RETURN
      IF(MSTJ(14).EQ.0) GOTO 540
 
C...Find lowest-mass colour singlet jet system.
      NS=N
  140 NSIN=N-NS
      PDMIN=1D0+PARJ(32)
      IC=0
      DO 190 I=MAX(1,IP),N
        IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
        ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
          NSIN=NSIN+1
          IC=I
          DO 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.PDMIN) THEN
            PDMIN=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
 
C...Done if lowest-mass system above threshold for string frag.
      IF(PDMIN.GE.PARJ(32)) GOTO 540
 
C...Fill small-mass system as cluster.
      NSAV=N
      PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
      K(N+1,1)=11
      K(N+1,2)=91
      K(N+1,3)=IC1
      P(N+1,1)=DPC(1)
      P(N+1,2)=DPC(2)
      P(N+1,3)=DPC(3)
      P(N+1,4)=DPC(4)
      P(N+1,5)=PECM
 
C...Set up history, assuming cluster -> 2 hadrons.
      NBODY=2
      K(N+1,4)=N+2
      K(N+1,5)=N+3
      K(N+2,1)=1
      K(N+3,1)=1
      IF(MSTU(16).NE.2) THEN
        K(N+2,3)=N+1
        K(N+3,3)=N+1
      ELSE
        K(N+2,3)=IC1
        K(N+3,3)=IC2
      ENDIF
      K(N+2,4)=0
      K(N+3,4)=0
      K(N+2,5)=0
      K(N+3,5)=0
      V(N+1,5)=0D0
      V(N+2,5)=0D0
      V(N+3,5)=0D0
 
C...Form two particles from flavours of lowest-mass system, if feasible.
      NTRY = 0
  200 NTRY = NTRY + 1
C...Open string.
      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 540
        KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2))
        KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2))
        IF(KQ1+KQ2.NE.0) GOTO 540
C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
  210   K1=K(IC1,2)
        IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2)
        MSTU(125)=0
        CALL PYDCYK(K1,0,KFLN,K(N+2,2))
        CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210
C...Closed string.
      ELSE
        IF(IABS(K(IC2,2)).NE.21) GOTO 540
C...No room for popcorn mesons in closed string -> 2 hadrons.
        MSTU(125)=0
  220   CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
        CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
        CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 220
      ENDIF
      P(N+2,5)=PYMASS(K(N+2,2))
      P(N+3,5)=PYMASS(K(N+3,2))
 
C...If it does not work: try again (a number of times), give up
C...(if no place to shuffle momentum), or form one hadron.
      IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
        IF(NTRY.LT.MSTJ(17)) THEN
          GOTO 200
        ELSEIF(NSIN.EQ.1) THEN
          GOTO 540
        ELSE
          GOTO 290
        END IF
      END IF
 
C...Perform two-particle decay of jet system.
C...First step: find reference axis in decaying system rest frame.
C...(Borrow slot N+2 for temporary direction.)
      DO 230 J=1,4
        P(N+2,J)=P(IC1,J)
  230 CONTINUE
      DO 250 I=IC1+1,IC2-1
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
     &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
          DO 240 J=1,4
            P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
  240     CONTINUE
        ENDIF
  250 CONTINUE
      CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
     &-DPC(3)/DPC(4))
      THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
      PHI1=PYANGL(P(N+2,1),P(N+2,2))
 
C...Second step: generate isotropic/anisotropic decay.
      PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
     &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
  260 UE(3)=PYR(0)
      PT2=(1D0-UE(3)**2)*PA**2
      IF(MSTJ(16).LE.0) THEN
        PREV=0.5D0
      ELSE
        IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260
        PR1=P(N+2,5)**2+PT2
        PR2=P(N+3,5)**2+PT2
        ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
        PREVCF=PARJ(42)
        IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
        PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD)))
      ENDIF
      IF(PYR(0).LT.PREV) UE(3)=-UE(3)
      PHI=PARU(2)*PYR(0)
      UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
      UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
      DO 270 J=1,3
        P(N+2,J)=PA*UE(J)
        P(N+3,J)=-PA*UE(J)
  270 CONTINUE
      P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
      P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
 
C...Third step: move back to event frame and set production vertex.
      CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
     &DPC(3)/DPC(4))
      DO 280 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
        V(N+3,J)=V(IC2,J)
  280 CONTINUE
      N=N+3
      GOTO 520
 
C...Else form one particle, if possible.
  290 NBODY=1
      K(N+1,5)=N+2
      DO 300 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
  300 CONTINUE
 
C...Select hadron flavour from available quark flavours.
  310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN
        GOTO 540
      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 310
      P(N+2,5)=PYMASS(K(N+2,2))
 
C...Use old algorithm for E/p conservation? (EN)
      IF (MSTJ(16).LE.0) GOTO 480
 
C...Find the string piece closest to the cluster by a loop
C...over the undecayed partons not in present cluster. (EN)
      DGLOMI=1D30
      IBEG=0
      I0=0
      DO 340 I1=MAX(1,IP),N-1
        IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
          I0=0
        ELSEIF(K(I1,1).EQ.2) THEN
          IF(I0.EQ.0) I0=I1
          I2=I1
  320     I2=I2+1
          IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320
 
C...Define velocity vectors e1, e2, ecl and differences e3, e4.
          DO 330 J=1,3
            E1(J)=P(I1,J)/P(I1,4)
            E2(J)=P(I2,J)/P(I2,4)
            ECL(J)=P(N+1,J)/P(N+1,4)
            E3(J)=E2(J)-E1(J)
            E4(J)=ECL(J)-E1(J)
  330     CONTINUE
 
C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
          E3S=E3(1)**2+E3(2)**2+E3(3)**2
          E4S=E4(1)**2+E4(2)**2+E4(3)**2
          E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
          IF(E34.LE.0D0) THEN
            DDMIN=E4S
          ELSEIF(E34.LT.E3S) THEN
            DDMIN=E4S-E34**2/E3S
          ELSE
            DDMIN=E4S-2D0*E34+E3S
          ENDIF
 
C...Is this the smallest so far?
          IF(DDMIN.LT.DGLOMI) THEN
            DGLOMI=DDMIN
            IBEG=I0
            IPCS=I1
          ENDIF
        ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
          I0=0
        ENDIF
  340 CONTINUE
 
C... Check if there are any strings to connect to the new gluon. (EN)
      IF (IBEG.EQ.0) GOTO 480
 
C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
      IF (P(N+1,5).GE.P(N+2,5)) THEN
 
C...Construct 'gluon' that is needed to put hadron on the mass shell.
        FRAC=P(N+2,5)/P(N+1,5)
        DO 350 J=1,5
          P(N+2,J)=FRAC*P(N+1,J)
          PG(J)=(1D0-FRAC)*P(N+1,J)
  350   CONTINUE
 
C... Copy string with new gluon put in.
        N=N+2
        I=IBEG-1
  360   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360
        N=N+1
        DO 370 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
  370   CONTINUE
        K(I,1)=K(I,1)+10
        K(I,4)=N
        K(I,5)=N
        K(N,3)=I
        IF(I.EQ.IPCS) THEN
          N=N+1
          DO 380 J=1,5
            K(N,J)=K(N-1,J)
            P(N,J)=PG(J)
            V(N,J)=V(N-1,J)
  380     CONTINUE
          K(N,2)=21
          K(N,3)=NSAV+1
        ENDIF
        IF(K(I,1).EQ.12) GOTO 360
        GOTO 520
 
C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
C...from string piece endpoints.
      ELSE
 
C...Begin by copying string that should give energy to cluster.
        N=N+2
        I=IBEG-1
  390   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390
        N=N+1
        DO 400 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
  400   CONTINUE
        K(I,1)=K(I,1)+10
        K(I,4)=N
        K(I,5)=N
        K(N,3)=I
        IF(I.EQ.IPCS) I1=N
        IF(K(I,1).EQ.12) GOTO 390
        I2=I1+1
 
C...Set initial Phad.
        DO 410 J=1,4
          P(NSAV+2,J)=P(NSAV+1,J)
  410   CONTINUE
 
C...Calculate Pg, a part of which will be added to Phad later. (EN)
  420   IF(MSTJ(16).EQ.1) THEN
          ALPHA=1D0
          BETA=1D0
        ELSE
          ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
          BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
        ENDIF
        DO 430 J=1,4
          PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
  430   CONTINUE
        PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
 
C..Solve 2nd order equation, use the best (smallest) solution. (EN)
        PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
     &  P(NSAV+2,3)**2
        PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
     &  P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
        DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
 
C...If all gluon energy eaten, zero it and take a step back.
        ITER=0
        IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN
          ITER=1
          DO 440 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
            P(I1,J)=0D0
  440     CONTINUE
          P(I1,5)=0D0
          I1=I1-1
        ENDIF
        IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN
          ITER=1
          DO 450 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
            P(I2,J)=0D0
  450     CONTINUE
          P(I2,5)=0D0
          I2=I2+1
        ENDIF
        IF(ITER.EQ.1) GOTO 420
 
C...If also all endpoint energy eaten, revert to old procedure.
        IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
     &  (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN
          DO 460 I=NSAV+3,N
            IM=K(I,3)
            K(IM,1)=K(IM,1)-10
            K(IM,4)=0
            K(IM,5)=0
  460     CONTINUE
          N=NSAV
          GOTO 480
        ENDIF
 
C... Construct the collapsed hadron and modified string partons.
        DO 470 J=1,4
          P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
          P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
          P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
  470   CONTINUE
          P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
          P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
 
C...Finished with string collapse in new scheme.
        GOTO 520
      ENDIF
 
C... Use old algorithm; by choice or when in trouble.
  480 CONTINUE
C...Find parton/particle which combines to largest extra mass.
      IR=0
      HA=0D0
      HSM=0D0
      DO 500 MCOMB=1,3
        IF(IR.NE.0) GOTO 500
        DO 490 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 490
          IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
          IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490
          IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490
          IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
     &    GOTO 490
          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
  490   CONTINUE
  500 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 510 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)
  510   CONTINUE
        N=N+2
      ELSE
        CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
        RETURN
      ENDIF
 
C...Mark collapsed system and store daughter pointers. Iterate.
  520 DO 530 I=IC1,IC2
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
     &  KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          K(I,1)=K(I,1)+10
          IF(MSTU(16).NE.2) THEN
            K(I,4)=NSAV+1
            K(I,5)=NSAV+1
          ELSE
            K(I,4)=NSAV+2
            K(I,5)=NSAV+1+NBODY
          ENDIF
        ENDIF
  530 CONTINUE
      IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140
 
C...Check flavours and invariant masses in parton systems.
  540 NP=0
      KFN=0
      KQS=0
      DO 550 J=1,5
        DPS(J)=0D0
  550 CONTINUE
      DO 580 I=MAX(1,IP),N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580
        KC=PYCOMP(K(I,2))
        IF(KC.EQ.0) GOTO 580
        KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
        IF(KQ.EQ.0) GOTO 580
        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 560 J=1,4
          DPS(J)=DPS(J)+P(I,J)
  560   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) THEN
            CALL PYERRM(3,'(PYPREP:) too small mass in jet system')
          END IF
          NP=0
          KFN=0
          KQS=0
          DO 570 J=1,5
            DPS(J)=0D0
  570     CONTINUE
        ENDIF
  580 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSTRF
C...Handles the fragmentation of an arbitrary colour singlet
C...jet system according to the Lund string fragmentation model.
 
      SUBROUTINE PYSTRF(IP)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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. All MOPS variables ends with MO
      DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
     &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5),
     &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
     &INMO(9),PM2QMO(2),XTMO(2)
 
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=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
            P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
            P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
          ELSE
            HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
            P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
            P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
          ENDIF
  130   CONTINUE
      ENDIF
 
C...Search for very nearby partons that may be recombined.
      NTRYR=0
      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
      IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
     &     ' junction strings not handled by MSTJ(12)>3 options')
      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(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 890
          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.. MOPS variables and switches
      NRVMO=0
      XBMO=1D0
      MSTU(121)=0
      MSTU(122)=0
 
C...Initialize flavour and pT variables for open string.
      IF(NS.LT.NR) THEN
        PX(1)=0D0
        PY(1)=0D0
        IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
        PX(2)=-PX(1)
        PY(2)=-PY(1)
        DO 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)
        IBMO=0
  700   CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
C.. Closed string: first vertex diq attempt => enforced second
C.. vertex diq
        IF(IABS(KFL(1)).GT.10)THEN
           IBMO=1
           MSTU(121)=0
           GOTO 700
        ENDIF
        IF(IBMO.EQ.1) MSTU(121)=-1
        KFL(2)=-KFL(1)
        CALL PYPTDI(KFL(1),PX(1),PY(1))
        PX(2)=-PX(1)
        PY(2)=-PY(1)
        PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
  710   CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
        ZR=PR3/(Z*P(N+NR+1,5)**2)
        IF(ZR.GE.1D0) GOTO 710
        DO 720 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
  720   CONTINUE
      ENDIF
C.. MOPS variables
      DO 730 JT=1,2
         XTMO(JT)=1D0
         PM2QMO(JT)=PMQ(JT)**2
         IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
  730 CONTINUE
 
C...Find initial transverse directions (i.e. spacelike four-vectors).
      DO 770 JT=1,2
        IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN
          IN1=IN(3*JT+1)
          IN3=IN(3*JT+3)
          DO 740 J=1,4
            DP(1,J)=P(IN1,J)
            DP(2,J)=P(IN1+1,J)
            DP(3,J)=0D0
            DP(4,J)=0D0
  740     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 750 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))
  750     CONTINUE
        ELSE
          DO 760 J=1,4
            P(IN3+2,J)=P(IN3,J)
            P(IN3+3,J)=P(IN3+1,J)
  760     CONTINUE
        ENDIF
  770 CONTINUE
 
C...Remove energy used up in junction string fragmentation.
      IF(MJU(1)+MJU(2).GT.0) THEN
        DO 790 JT=1,2
          IF(NJS(JT).EQ.0) GOTO 790
          DO 780 J=1,4
            P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
  780     CONTINUE
  790   CONTINUE
      ENDIF
 
C...Produce new particle: side, origin.
  800 I=I+1
      IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
        CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
C.. New side priority for popcorn systems
      IF(MSTU(121).LE.0)THEN
         JT=1.5D0+PYR(0)
         IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
         IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
      ENDIF
      JR=3-JT
      JS=3-2*JT
      IRANK(JT)=IRANK(JT)+1
      K(I,1)=1
      K(I,3)=IE(JT)
      K(I,4)=0
      K(I,5)=0
 
C...Generate flavour, hadron and pT.
  810 CONTINUE
      CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
      IF(K(I,2).EQ.0) GOTO 640
      MU90MO=MSTU(90)
      IF(MSTU(121).EQ.-1) GOTO 840
      IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
     &IABS(KFL(3)).GT.10) THEN
        IF(PYR(0).GT.PARJ(19)) GOTO 810
      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 1010
 
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 1010
      ENDIF
      GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
 
C.. MOPS baryon model modification
      XTMO3=(1D0-Z)*XTMO(JT)
      IF(IABS(KFL(3)).LE.10) NRVMO=0
      IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
         GTSTMO=1D0
         PTSTMO=1D0
         RTSTMO=PYR(0)
         IF(IABS(KFL(JT)).LE.10)THEN
            XBMO=MIN(XTMO3,1D0-(2D-10))
            GBMO=GAM(3)
            PMMO=0D0
            PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
            GTSTMO=1D0-PARF(192)**PGMO
         ELSE
            IF(IRANK(JT).EQ.1) THEN
               GBMO=GAM(JT)
               PMMO=0D0
               XBMO=1D0
            ENDIF
            IF(XBMO.LT.1D0-(1D-10))THEN
               PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
               GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
               PGMO=PGNMO
            ENDIF
            IF(MSTJ(12).GE.5)THEN
               PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
               PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
               PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
               PMMO=PMNMO
            ENDIF
         ENDIF
 
C.. MOPS Accepting popcorn system hadron.
         IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
            IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
               NRVMO=I-N-NR
               IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
                  CALL PYERRM(11,
     &                 '(PYSTRF:) no more memory left in PYJETS')
                  IF(MSTU(21).GE.1) RETURN
               ENDIF
               IMO=I
               KFLMO=KFL(JT)
               PMQMO=PMQ(JT)
               PXMO=PX(JT)
               PYMO=PY(JT)
               GAMMO=GAM(JT)
               IRMO=IRANK(JT)
               XMO=XTMO(JT)
               DO 830 J=1,9
                  IF(J.LE.5) THEN
                     DO 820 LINE=1,I-N-NR
                        P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
                        K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
  820                CONTINUE
                  ENDIF
                  INMO(J)=IN(J)
  830          CONTINUE
            ENDIF
         ELSE
C..Reject popcorn system, flag=-1 if enforcing new one
            MSTU(121)=-1
            IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
         ENDIF
      ENDIF
 
 
C..Lift restoring string outside MOPS block
  840 IF(MSTU(121).LT.0) THEN
         IF(MSTU(121).EQ.-2) MSTU(121)=0
         MSTU(90)=MU90MO
         NRVMO=0
         IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810
         I=IMO
         KFL(JT)=KFLMO
         PMQ(JT)=PMQMO
         PX(JT)=PXMO
         PY(JT)=PYMO
         GAM(JT)=GAMMO
         IRANK(JT)=IRMO
         XTMO(JT)=XMO
         DO 860 J=1,9
            IF(J.LE.5) THEN
               DO 850 LINE=1,I-N-NR
                  P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
                  K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
  850          CONTINUE
            ENDIF
            IN(J)=INMO(J)
  860    CONTINUE
         GOTO 810
      ENDIF
      XTMO(JT)=XTMO3
C.. MOPS end of modification
 
      DO 870 J=1,3
        IN(J)=IN(3*JT+J)
  870 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 880 J=1,4
          P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
  880   CONTINUE
        GOTO 970
      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).
  890 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 900 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
  900   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 890
        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 910 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))
  910   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 940 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 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
          P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
  920   CONTINUE
        DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
          P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
  930   CONTINUE
  940 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 960 IN2=IN(1)+1,IN(2),4
        DO 950 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
  950   CONTINUE
  960 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 890
      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 890
      ENDIF
 
C...Four-momentum of particle. Remaining quantities. Loop back.
  970 DO 980 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)
  980 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 990 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)
  990   CONTINUE
      ENDIF
      DO 1000 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)
 1000 CONTINUE
      GOTO 800
 
C...Final hadron: side, flavour, hadron, mass.
 1010 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)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
      DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
      DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
      DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
      IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
        PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
        PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
        PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
     &  PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
      ENDIF
 
C...Solve kinematics for final two hadrons, if possible.
      WREM2=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)
      FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
      PREVCF=PARJ(42)
      IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
      PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB)))
      FB=SIGN(FB,JS*(PYR(0)-PREV))
      KFL1A=IABS(KFL(1))
      KFL2A=IABS(KFL(2))
      IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
     &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
     &4D0*WREM2*PR(JT))),DBLE(JS))
      DO 1020 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)
 1020 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 1030 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
 1030 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 1040 J=1,4
        P(NSAV,J)=DPS(J)
        V(NSAV,J)=V(IP,J)
 1040 CONTINUE
      P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
      V(NSAV,5)=0D0
      DO 1060 I=NSAV+1,N
        DO 1050 J=1,5
          K(I,J)=K(I+NRS-1,J)
          P(I,J)=P(I+NRS-1,J)
          V(I,J)=0D0
 1050   CONTINUE
 1060 CONTINUE
      MSTU91=MSTU(90)
      DO 1070 IZ=MSTU90+1,MSTU91
        MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
        PARU9T(IZ)=PARU(90+IZ)
 1070 CONTINUE
      MSTU(90)=MSTU90
 
C...Order particles in rank along the chain. Update mother pointer.
      DO 1090 I=NSAV+1,N
        DO 1080 J=1,5
          K(I-NSAV+N,J)=K(I,J)
          P(I-NSAV+N,J)=P(I,J)
 1080   CONTINUE
 1090 CONTINUE
      I1=NSAV
      DO 1120 I=N+1,2*N-NSAV
        IF(K(I,3).NE.IE(1)) GOTO 1120
        I1=I1+1
        DO 1100 J=1,5
          K(I1,J)=K(I,J)
          P(I1,J)=P(I,J)
 1100   CONTINUE
        IF(MSTU(16).NE.2) K(I1,3)=NSAV
        DO 1110 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
 1110   CONTINUE
 1120 CONTINUE
      DO 1150 I=2*N-NSAV,N+1,-1
        IF(K(I,3).EQ.IE(1)) GOTO 1150
        I1=I1+1
        DO 1130 J=1,5
          K(I1,J)=K(I,J)
          P(I1,J)=P(I,J)
 1130   CONTINUE
        IF(MSTU(16).NE.2) K(I1,3)=NSAV
        DO 1140 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
 1140   CONTINUE
 1150 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 1160 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
 1160   CONTINUE
      ENDIF
      DO 1180 I=NSAV+1,N
        DO 1170 J=1,4
          V(I,J)=V(IP,J)
 1170   CONTINUE
 1180 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)
      IMPLICIT INTEGER(I-N)
      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.. MOPS error message
      IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
     &' are not treated as expected in independent fragmentation')
 
C...Reset counters. Identify parton system and take copy. Check flavour.
      NSAV=N
      MSTU90=MSTU(90)
      NJET=0
      KQSUM=0
      DO 100 J=1,5
        DPS(J)=0D0
  100 CONTINUE
      I=IP-1
  110 I=I+1
      IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
        CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
      IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
      KC=PYCOMP(K(I,2))
      IF(KC.EQ.0) GOTO 110
      KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
      IF(KQ.EQ.0) GOTO 110
      NJET=NJET+1
      IF(KQ.NE.2) KQSUM=KQSUM+KQ
      DO 120 J=1,5
        K(NSAV+NJET,J)=K(I,J)
        P(NSAV+NJET,J)=P(I,J)
        DPS(J)=DPS(J)+P(I,J)
  120 CONTINUE
      K(NSAV+NJET,3)=I
      IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
     &K(I+1,1).EQ.2)) GOTO 110
      IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
        CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
 
C...Boost copied system to CM frame. Find CM energy and sum flavours.
      IF(NJET.NE.1) THEN
        MSTU(33)=1
        CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
     &  -DPS(2)/DPS(4),-DPS(3)/DPS(4))
      ENDIF
      PECM=0D0
      DO 130 J=1,3
        NFI(J)=0
  130 CONTINUE
      DO 140 I=NSAV+1,NSAV+NJET
        PECM=PECM+P(I,4)
        KFA=IABS(K(I,2))
        IF(KFA.LE.3) THEN
          NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
        ELSEIF(KFA.GT.1000) THEN
          KFLA=MOD(KFA/1000,10)
          KFLB=MOD(KFA/100,10)
          IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
          IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
        ENDIF
  140 CONTINUE
 
C...Loop over attempts made. Reset counters.
      NTRY=0
  150 NTRY=NTRY+1
      IF(NTRY.GT.200) THEN
        CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
      N=NSAV+NJET
      MSTU(90)=MSTU90
      DO 160 J=1,3
        NFL(J)=NFI(J)
        IFET(J)=0
        KFLF(J)=0
  160 CONTINUE
 
C...Loop over jets to be fragmented.
      DO 230 IP1=NSAV+1,NSAV+NJET
        MSTJ(91)=0
        NSAV1=N
        MSTU91=MSTU(90)
 
C...Initial flavour and momentum values. Jet along +z axis.
        KFLH=IABS(K(IP1,2))
        IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
        KFLO(2)=0
        WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
 
C...Initial values for quark or diquark jet.
  170   IF(IABS(K(IP1,2)).NE.21) THEN
          NSTR=1
          KFLO(1)=K(IP1,2)
          CALL PYPTDI(0,PXO(1),PYO(1))
          WO(1)=WF
 
C...Initial values for gluon treated like random quark jet.
        ELSEIF(MSTJ(2).LE.2) THEN
          NSTR=1
          IF(MSTJ(2).EQ.2) MSTJ(91)=1
          KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
          CALL PYPTDI(0,PXO(1),PYO(1))
          WO(1)=WF
 
C...Initial values for gluon treated like quark-antiquark jet pair,
C...sharing energy according to Altarelli-Parisi splitting function.
        ELSE
          NSTR=2
          IF(MSTJ(2).EQ.4) MSTJ(91)=1
          KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
          KFLO(2)=-KFLO(1)
          CALL PYPTDI(0,PXO(1),PYO(1))
          PXO(2)=-PXO(1)
          PYO(2)=-PYO(1)
          WO(1)=WF*PYR(0)**(1D0/3D0)
          WO(2)=WF-WO(1)
        ENDIF
 
C...Initial values for rank, flavour, pT and W+.
        DO 220 ISTR=1,NSTR
  180     I=N
          MSTU(90)=MSTU91
          IRANK=0
          KFL1=KFLO(ISTR)
          PX1=PXO(ISTR)
          PY1=PYO(ISTR)
          W=WO(ISTR)
 
C...New hadron. Generate flavour and hadron species.
  190     I=I+1
          IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
            CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
            IF(MSTU(21).GE.1) RETURN
          ENDIF
          IRANK=IRANK+1
          K(I,1)=1
          K(I,3)=IP1
          K(I,4)=0
          K(I,5)=0
  200     CALL PYKFDI(KFL1,0,KFL2,K(I,2))
          IF(K(I,2).EQ.0) GOTO 180
          IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
            IF(PYR(0).GT.PARJ(19)) GOTO 200
          ENDIF
 
C...Find hadron mass. Generate four-momentum.
          P(I,5)=PYMASS(K(I,2))
          CALL PYPTDI(KFL1,PX2,PY2)
          P(I,1)=PX1+PX2
          P(I,2)=PY1+PY2
          PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
          CALL PYZDIS(KFL1,KFL2,PR,Z)
          MZSAV=0
          IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
            MZSAV=1
            MSTU(90)=MSTU(90)+1
            MSTU(90+MSTU(90))=I
            PARU(90+MSTU(90))=Z
          ENDIF
          P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
          P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
          IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
     &    P(I,3).LE.0.001D0) THEN
            IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
            P(I,3)=0.0001D0
            P(I,4)=SQRT(PR)
            Z=P(I,4)/W
          ENDIF
 
C...Remaining flavour and momentum.
          KFL1=-KFL2
          PX1=-PX2
          PY1=-PY2
          W=(1D0-Z)*W
          DO 210 J=1,5
            V(I,J)=0D0
  210     CONTINUE
 
C...Check if pL acceptable. Go back for new hadron if enough energy.
          IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
            I=I-1
            IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
          ENDIF
          IF(W.GT.PARJ(31)) GOTO 190
          N=I
  220   CONTINUE
        IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
        IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
 
C...Rotate jet to new direction.
        THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
        PHI=PYANGL(P(IP1,1),P(IP1,2))
        MSTU(33)=1
        CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
        K(K(IP1,3),4)=NSAV1+1
        K(K(IP1,3),5)=N
 
C...End of jet generation loop. Skip conservation in some cases.
  230 CONTINUE
      IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
      IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
 
C...Subtract off produced hadron flavours, finished if zero.
      DO 240 I=NSAV+NJET+1,N
        KFA=IABS(K(I,2))
        KFLA=MOD(KFA/1000,10)
        KFLB=MOD(KFA/100,10)
        KFLC=MOD(KFA/10,10)
        IF(KFLA.EQ.0) THEN
          IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
          IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
        ELSE
          IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
          IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
          IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
        ENDIF
  240 CONTINUE
      NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
     &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
      IF(NREQ.EQ.0) GOTO 320
 
C...Take away flavour of low-momentum particles until enough freedom.
      NREM=0
  250 IREM=0
      P2MIN=PECM**2
      DO 260 I=NSAV+NJET+1,N
        P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
        IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
        IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
  260 CONTINUE
      IF(IREM.EQ.0) GOTO 150
      K(IREM,1)=7
      KFA=IABS(K(IREM,2))
      KFLA=MOD(KFA/1000,10)
      KFLB=MOD(KFA/100,10)
      KFLC=MOD(KFA/10,10)
      IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
      IF(K(IREM,1).EQ.8) GOTO 250
      IF(KFLA.EQ.0) THEN
        ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
        IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
        IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
      ELSE
        IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
        IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
        IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
      ENDIF
      NREM=NREM+1
      NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
     &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
      IF(NREQ.GT.NREM) GOTO 250
      DO 270 I=NSAV+NJET+1,N
        IF(K(I,1).EQ.8) K(I,1)=1
  270 CONTINUE
 
C...Find combination of existing and new flavours for hadron.
  280 NFET=2
      IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
      IF(NREQ.LT.NREM) NFET=1
      IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
      DO 290 J=1,NFET
        IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
        KFLF(J)=ISIGN(1,NFL(1))
        IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
        IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
  290 CONTINUE
      IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
     &GOTO 280
      IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
     &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
     &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
      IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
      IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
      IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
      IF(NFET.LE.2) KFLF(3)=0
      IF(KFLF(3).NE.0) THEN
        KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
     &  100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
        IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
     &  KFLFC=KFLFC+ISIGN(2,KFLFC)
      ELSE
        KFLFC=KFLF(1)
      ENDIF
      CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
      IF(KF.EQ.0) GOTO 280
      DO 300 J=1,MAX(2,NFET)
        NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
  300 CONTINUE
 
C...Store hadron at random among free positions.
      NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
      DO 310 I=NSAV+NJET+1,N
        IF(K(I,1).EQ.7) NPOS=NPOS-1
        IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
        K(I,1)=1
        K(I,2)=KF
        P(I,5)=PYMASS(K(I,2))
        P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
  310 CONTINUE
      NREM=NREM-1
      NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
     &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
      IF(NREM.GT.0) GOTO 280
 
C...Compensate for missing momentum in global scheme (3 options).
  320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
        DO 340 J=1,3
          PSI(J)=0D0
          DO 330 I=NSAV+NJET+1,N
            PSI(J)=PSI(J)+P(I,J)
  330     CONTINUE
  340   CONTINUE
        PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
        PWS=0D0
        DO 350 I=NSAV+NJET+1,N
          IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
          IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
     &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
          IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
  350   CONTINUE
        DO 370 I=NSAV+NJET+1,N
          IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
          IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
     &    PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
          IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
          DO 360 J=1,3
            P(I,J)=P(I,J)-PSI(J)*PW/PWS
  360     CONTINUE
          P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
  370   CONTINUE
 
C...Compensate for missing momentum withing each jet separately.
      ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
        DO 390 I=N+1,N+NJET
          K(I,1)=0
          DO 380 J=1,5
            P(I,J)=0D0
  380     CONTINUE
  390   CONTINUE
        DO 410 I=NSAV+NJET+1,N
          IR1=K(I,3)
          IR2=N+IR1-NSAV
          K(IR2,1)=K(IR2,1)+1
          PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
     &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
          DO 400 J=1,3
            P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
  400     CONTINUE
          P(IR2,4)=P(IR2,4)+P(I,4)
          P(IR2,5)=P(IR2,5)+PLS
  410   CONTINUE
        PSS=0D0
        DO 420 I=N+1,N+NJET
          IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
  420   CONTINUE
        DO 440 I=NSAV+NJET+1,N
          IR1=K(I,3)
          IR2=N+IR1-NSAV
          PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
     &    (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
          DO 430 J=1,3
            P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
     &      PLS*P(IR1,J)
  430     CONTINUE
          P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
  440   CONTINUE
      ENDIF
 
C...Scale momenta for energy conservation.
      IF(MOD(MSTJ(3),5).NE.0) THEN
        PMS=0D0
        PES=0D0
        PQS=0D0
        DO 450 I=NSAV+NJET+1,N
          PMS=PMS+P(I,5)
          PES=PES+P(I,4)
          PQS=PQS+P(I,5)**2/P(I,4)
  450   CONTINUE
        IF(PMS.GE.PECM) GOTO 150
        NECO=0
  460   NECO=NECO+1
        PFAC=(PECM-PQS)/(PES-PQS)
        PES=0D0
        PQS=0D0
        DO 480 I=NSAV+NJET+1,N
          DO 470 J=1,3
            P(I,J)=PFAC*P(I,J)
  470     CONTINUE
          P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
          PES=PES+P(I,4)
          PQS=PQS+P(I,5)**2/P(I,4)
  480   CONTINUE
        IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
      ENDIF
 
C...Origin of produced particles and parton daughter pointers.
  490 DO 500 I=NSAV+NJET+1,N
        IF(MSTU(16).NE.2) K(I,3)=NSAV+1
        IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
  500 CONTINUE
      DO 510 I=NSAV+1,NSAV+NJET
        I1=K(I,3)
        K(I1,1)=K(I1,1)+10
        IF(MSTU(16).NE.2) THEN
          K(I1,4)=NSAV+1
          K(I1,5)=NSAV+1
        ELSE
          K(I1,4)=K(I1,4)-NJET+1
          K(I1,5)=K(I1,5)-NJET+1
          IF(K(I1,5).LT.K(I1,4)) THEN
            K(I1,4)=0
            K(I1,5)=0
          ENDIF
        ENDIF
  510 CONTINUE
 
C...Document independent fragmentation system. Remove copy of jets.
      NSAV=NSAV+1
      K(NSAV,1)=11
      K(NSAV,2)=93
      K(NSAV,3)=IP
      K(NSAV,4)=NSAV+1
      K(NSAV,5)=N-NJET+1
      DO 520 J=1,4
        P(NSAV,J)=DPS(J)
        V(NSAV,J)=V(IP,J)
  520 CONTINUE
      P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
      V(NSAV,5)=0D0
      DO 540 I=NSAV+NJET,N
        DO 530 J=1,5
          K(I-NJET+1,J)=K(I,J)
          P(I-NJET+1,J)=P(I,J)
          V(I-NJET+1,J)=V(I,J)
  530   CONTINUE
  540 CONTINUE
      N=N-NJET+1
      DO 550 IZ=MSTU90+1,MSTU(90)
        MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
  550 CONTINUE
 
C...Boost back particle system. Set production vertices.
      IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
     &DPS(2)/DPS(4),DPS(3)/DPS(4))
      DO 570 I=NSAV+1,N
        DO 560 J=1,4
          V(I,J)=V(IP,J)
  560   CONTINUE
  570 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYDECY
C...Handles the decay of unstable particles.
 
      SUBROUTINE PYDECY(IP)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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
C...Do not print warning for some well-known special cases.
        IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
     &  CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
     &  CIDC)
        GOTO 240
      ENDIF
      IF(NTRY.GT.1000) THEN
        CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
      I=N
      NP=0
      NQ=0
      MBST=0
      IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
      DO 270 J=1,4
        PV(1,J)=0D0
        IF(MBST.EQ.0) PV(1,J)=P(IP,J)
  270 CONTINUE
      IF(MBST.EQ.1) PV(1,4)=P(IP,5)
      PV(1,5)=P(IP,5)
      PS=0D0
      PSQ=0D0
      MREM=0
      MHADDY=0
      IF(KFA.GT.80) MHADDY=1
C.. Random flavour and popcorn system memory.
      IRNDMO=0
      JTMO=0
      MSTU(121)=0
      MSTU(125)=10
 
C...Read out decay products. Convert to standard flavour code.
      JTMAX=5
      IF(MDME(IDC+1,2).EQ.101) JTMAX=10
      DO 280 JT=1,JTMAX
        IF(JT.LE.5) KP=KFDP(IDC,JT)
        IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
        IF(KP.EQ.0) GOTO 280
        KPA=IABS(KP)
        KCP=PYCOMP(KPA)
        IF(KPA.GT.80) MHADDY=1
        IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
          KFP=KP
        ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
          KFP=KFS*KP
        ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
          KFP=-KFS*MOD(KFA/10,10)
        ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
          KFP=KFS*(100*MOD(KFA/10,100)+3)
        ELSEIF(KPA.EQ.81) THEN
          KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
        ELSEIF(KP.EQ.82) THEN
          CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
          IF(KFP.EQ.0) GOTO 260
          KFP=-KFP
          IRNDMO=1
          MSTJ(93)=1
          IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
        ELSEIF(KP.EQ.-82) THEN
          KFP=MSTU(124)
        ENDIF
        IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
 
C...Add decay product to event record or to quark flavour list.
        KFPA=IABS(KFP)
        KQP=KCHG(KCP,2)
        IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
          NQ=NQ+1
          KFLO(NQ)=KFP
C...set rndmflav popcorn system pointer
          IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
          MSTJ(93)=2
          PSQ=PSQ+PYMASS(KFLO(NQ))
        ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
     &    MOD(NQ,2).EQ.1) THEN
          NQ=NQ-1
          PS=PS-P(I,5)
          K(I,1)=1
          KFI=K(I,2)
          CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
          IF(K(I,2).EQ.0) GOTO 260
          MSTJ(93)=1
          P(I,5)=PYMASS(K(I,2))
          PS=PS+P(I,5)
        ELSE
          I=I+1
          NP=NP+1
          IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
          IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
          K(I,1)=1+MOD(NQ,2)
          IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
          IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
          K(I,2)=KFP
          K(I,3)=IP
          K(I,4)=0
          K(I,5)=0
          P(I,5)=PYMASS(KFP)
          PS=PS+P(I,5)
        ENDIF
  280 CONTINUE
 
C...Check masses for resonance decays.
      IF(MHADDY.EQ.0) THEN
        IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
      ENDIF
 
C...Choose decay multiplicity in phase space model.
  290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
        PSP=PS
        CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
        IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
  300   NTRY=NTRY+1
C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
        IF(IRNDMO.EQ.0) THEN
           MSTU(121)=0
           JTMO=0
        ELSEIF(IRNDMO.EQ.1) THEN
           IRNDMO=2
        ELSE
           GOTO 260
        ENDIF
        IF(NTRY.GT.1000) THEN
          CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
          IF(MSTU(21).GE.1) RETURN
        ENDIF
        IF(MMAT.LE.20) THEN
          GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
     &    SIN(PARU(2)*PYR(0))
          ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
          IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
          IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
          IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
          IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
        ELSE
          ND=MMAT-20
        ENDIF
C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
        MSTU(125)=ND-NQ/2
        IF(MSTU(121).GT.MSTU(125)) GOTO 300
 
C...Form hadrons from flavour content.
        DO 310 JT=1,NQ
          KFL1(JT)=KFLO(JT)
  310   CONTINUE
        IF(ND.EQ.NP+NQ/2) GOTO 330
        DO 320 I=N+NP+1,N+ND-NQ/2
C.. Stick to started popcorn system, else pick side at random
          JT=JTMO
          IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
          CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
          IF(K(I,2).EQ.0) GOTO 300
          MSTU(125)=MSTU(125)-1
          JTMO=0
          IF(MSTU(121).GT.0) JTMO=JT
          KFL1(JT)=-KFL2
  320   CONTINUE
  330   JT=2
        JT2=3
        JT3=4
        IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
        IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
     &  ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
        IF(JT.EQ.3) JT2=2
        IF(JT.EQ.4) JT3=2
        CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
        IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
        IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
        IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
 
C...Check that sum of decay product masses not too large.
        PS=PSP
        DO 340 I=N+NP+1,N+ND
          K(I,1)=1
          K(I,3)=IP
          K(I,4)=0
          K(I,5)=0
          P(I,5)=PYMASS(K(I,2))
          PS=PS+P(I,5)
  340   CONTINUE
        IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
 
C...Rescale energy to subtract off spectator quark mass.
      ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
     &  .AND.NP.GE.3) THEN
        PS=PS-P(N+NP,5)
        PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
        DO 350 J=1,5
          P(N+NP,J)=PQT*PV(1,J)
          PV(1,J)=(1D0-PQT)*PV(1,J)
  350   CONTINUE
        IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
        ND=NP-1
        MREM=1
 
C...Fully specified final state: check mass broadening effects.
      ELSE
        IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
        ND=NP
      ENDIF
 
C...Determine position of grandmother, number of sisters.
      NM=0
      KFAS=0
      MSGN=0
      IF(MMAT.EQ.3) THEN
        IM=K(IP,3)
        IF(IM.LT.0.OR.IM.GE.IP) IM=0
        IF(IM.NE.0) KFAM=IABS(K(IM,2))
        IF(IM.NE.0) THEN
          DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
            IF(K(IL,3).EQ.IM) NM=NM+1
            IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
  360     CONTINUE
          IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
     &    MOD(KFAM/1000,10).NE.0) NM=0
          IF(NM.EQ.2) THEN
            KFAS=IABS(K(ISIS,2))
            IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
     &      MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
          ENDIF
        ENDIF
      ENDIF
 
C...Kinematics of one-particle decays.
      IF(ND.EQ.1) THEN
        DO 370 J=1,4
          P(N+1,J)=P(IP,J)
  370   CONTINUE
        GOTO 630
      ENDIF
 
C...Calculate maximum weight ND-particle decay.
      PV(ND,5)=P(N+ND,5)
      IF(ND.GE.3) THEN
        WTMAX=1D0/WTCOR(ND-2)
        PMAX=PV(1,5)-PS+P(N+ND,5)
        PMIN=0D0
        DO 380 IL=ND-1,1,-1
          PMAX=PMAX+P(N+IL,5)
          PMIN=PMIN+P(N+IL+1,5)
          WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
  380   CONTINUE
      ENDIF
 
C...Find virtual gamma mass in Dalitz decay.
  390 IF(ND.EQ.2) THEN
      ELSEIF(MMAT.EQ.2) THEN
        PMES=4D0*PMAS(11,1)**2
        PMRHO2=PMAS(131,1)**2
        PGRHO2=PMAS(131,2)**2
  400   PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
        WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
     &  (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
     &  ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
        IF(WT.LT.PYR(0)) GOTO 400
        PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
 
C...M-generator gives weight. If rejected, try again.
      ELSE
  410   RORD(1)=1D0
        DO 440 IL1=2,ND-1
          RSAV=PYR(0)
          DO 420 IL2=IL1-1,1,-1
            IF(RSAV.LE.RORD(IL2)) GOTO 430
            RORD(IL2+1)=RORD(IL2)
  420     CONTINUE
  430     RORD(IL2+1)=RSAV
  440   CONTINUE
        RORD(ND)=0D0
        WT=1D0
        DO 450 IL=ND-1,1,-1
          PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
     &    (PV(1,5)-PS)
          WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
  450   CONTINUE
        IF(WT.LT.PYR(0)*WTMAX) GOTO 410
      ENDIF
 
C...Perform two-particle decays in respective CM frame.
  460 DO 480 IL=1,ND-1
        PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
        UE(3)=2D0*PYR(0)-1D0
        PHI=PARU(2)*PYR(0)
        UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
        UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
        DO 470 J=1,3
          P(N+IL,J)=PA*UE(J)
          PV(IL+1,J)=-PA*UE(J)
  470   CONTINUE
        P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
        PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
  480 CONTINUE
 
C...Lorentz transform decay products to lab frame.
      DO 490 J=1,4
        P(N+ND,J)=PV(ND,J)
  490 CONTINUE
      DO 530 IL=ND-1,1,-1
        DO 500 J=1,3
          BE(J)=PV(IL,J)/PV(IL,4)
  500   CONTINUE
        GA=PV(IL,4)/PV(IL,5)
        DO 520 I=N+IL,N+ND
          BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
          DO 510 J=1,3
            P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
  510     CONTINUE
          P(I,4)=GA*(P(I,4)+BEP)
  520   CONTINUE
  530 CONTINUE
 
C...Check that no infinite loop in matrix element weight.
      NTRY=NTRY+1
      IF(NTRY.GT.800) GOTO 560
 
C...Matrix elements for omega and phi decays.
      IF(MMAT.EQ.1) THEN
        WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
     &  -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
     &  +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
        IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
 
C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
      ELSEIF(MMAT.EQ.2) THEN
        FOUR12=FOUR(N+1,N+2)
        FOUR13=FOUR(N+1,N+3)
        WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
     &  PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
        IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
 
C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
C...V vector), of form cos**2(theta02) in V1 rest frame, and for
C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
      ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
        FOUR10=FOUR(IP,IM)
        FOUR12=FOUR(IP,N+1)
        FOUR02=FOUR(IM,N+1)
        PMS1=P(IP,5)**2
        PMS0=P(IM,5)**2
        PMS2=P(N+1,5)**2
        IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
        IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
     &  PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
        HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
        HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
        IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
 
C...Matrix element for "onium" -> g + g + g or gamma + g + g.
      ELSEIF(MMAT.EQ.4) THEN
        HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
        HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
        HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
        WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
     &  ((1D0-HX3)/(HX1*HX2))**2
        IF(WT.LT.2D0*PYR(0)) GOTO 390
        IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
     &  GOTO 390
 
C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
      ELSEIF(MMAT.EQ.41) THEN
        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...PYDCYK
C...Handles flavour production in the decay of unstable particles
C...and small string clusters.
 
      SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
 
C.. Call PYKFDI directly if no popcorn option is on
      IF(MSTJ(12).LT.2) THEN
         CALL PYKFDI(KFL1,KFL2,KFL3,KF)
         MSTU(124)=KFL3
         RETURN
      ENDIF
 
      KFL3=0
      KF=0
      IF(KFL1.EQ.0) RETURN
      KF1A=IABS(KFL1)
      KF2A=IABS(KFL2)
 
      NSTO=130
      NMAX=MIN(MSTU(125),10)
 
C.. Identify rank 0 cluster qq
      IRANK=1
      IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
 
      IF(KF2A.GT.0)THEN
C.. Join jets: Fails if store not empty
         IF(MSTU(121).GT.0) THEN
            MSTU(121)=0
            RETURN
         ENDIF
         CALL PYKFDI(KFL1,KFL2,KFL3,KF)
      ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
C.. Pick popcorn meson from store, return same qq, decrease store
         KF=MSTU(NSTO+MSTU(121))
         KFL3=-KFL1
         MSTU(121)=MSTU(121)-1
      ELSE
C.. Generate new flavour. Then done if no diquark is generated
  100    CALL PYKFDI(KFL1,0,KFL3,KF)
         IF(MSTU(121).EQ.-1) GOTO 100
         MSTU(124)=KFL3
         IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
 
C.. Simple case if no dynamical popcorn suppressions are considered
         IF(MSTJ(12).LT.4) THEN
            IF(MSTU(121).EQ.0) RETURN
            NMES=1
            KFPREV=-KFL3
            CALL PYKFDI(KFPREV,0,KFL3,KFM)
C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
            IF(IABS(KFL3).LE.10)THEN
               KFL3=-KFPREV
               RETURN
            ENDIF
            GOTO 120
         ENDIF
 
C test output qq against fake Gamma, then return if no popcorn.
         GB=2D0
         IF(IRANK.NE.0)THEN
            CALL PYZDIS(1,2103,5D0,Z)
            GB=5D0*(1D0-Z)/Z
            IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
               MSTU(121)=0
               GOTO 100
            ENDIF
         ENDIF
         IF(MSTU(121).EQ.0) RETURN
 
C..Set store size memory. Pick fake dynamical variables of qq.
         NMES=MSTU(121)
         CALL PYPTDI(1,PX3,PY3)
         X=1D0
         POPM=0D0
         G=GB
         POPG=GB
 
C.. Pick next popcorn meson, test with fake dynamical variables
  110    KFPREV=-KFL3
         PX1=-PX3
         PY1=-PY3
         CALL PYKFDI(KFPREV,0,KFL3,KFM)
         IF(MSTU(121).EQ.-1) GOTO 100
         CALL PYPTDI(KFL3,PX3,PY3)
         PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
         CALL PYZDIS(KFPREV,KFL3,PM,Z)
         G=(1D0-Z)*(G+PM/Z)
         X=(1D0-Z)*X
 
         PTST=1D0
         GTST=1D0
         RTST=PYR(0)
         IF(MSTJ(12).GT.4)THEN
            POPMN=SQRT((1D0-X)*(G/X-GB))
            POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
            PTST=EXP((POPM-POPMN)*PARF(193))
            POPM=POPMN
         ENDIF
         IF(IRANK.NE.0)THEN
            POPGN=X*GB
            GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
            POPG=POPGN
         ENDIF
         IF(RTST.GT.PTST*GTST)THEN
            MSTU(121)=0
            IF(RTST.GT.PTST) MSTU(121)=-1
            GOTO 100
         ENDIF
 
C.. Store meson
  120    IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
         IF(MSTU(121).GT.0) GOTO 110
 
C.. Test accepted system size. If OK set global popcorn size variable.
         IF(NMES.GT.NMAX)THEN
            KF=0
            KFL3=0
            RETURN
         ENDIF
         MSTU(121)=NMES
      ENDIF
 
      RETURN
      END
 
C********************************************************************
 
C...PYKFDI
C...Generates a new flavour pair and combines off a hadron
 
      SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
C...Local arrays.
      DIMENSION PD(7)
 
      IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0)  CALL PYKFIN

C...Default flavour values. Input consistency checks.
      KF1A=IABS(KFL1)
      KF2A=IABS(KFL2)
      KFL3=0
      KF=0
      IF(KF1A.EQ.0) RETURN
      IF(KF2A.NE.0)THEN
        IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
        IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
        IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
      ENDIF
 
C...Check if tabulated flavour probabilities are to be used.
      IF(MSTJ(15).EQ.1) THEN
        IF(MSTJ(12).GE.5)  CALL PYERRM(29,
     &        '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
     &        ' together with MSTJ(12)>=5 modification')
        KTAB1=-1
        IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
        KFL1A=MOD(KF1A/1000,10)
        KFL1B=MOD(KF1A/100,10)
        KFL1S=MOD(KF1A,10)
        IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
     &  KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
        IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
        IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
        KTAB2=0
        IF(KF2A.NE.0) THEN
          KTAB2=-1
          IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
          KFL2A=MOD(KF2A/1000,10)
          KFL2B=MOD(KF2A/100,10)
          KFL2S=MOD(KF2A,10)
          IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
     &    KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
          IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
        ENDIF
        IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
      ENDIF
 
C.. Recognize rank 0 diquark case
  100 IRANK=1
      KFDIQ=MAX(KF1A,KF2A)
      IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
 
C.. Join two flavours to meson or baryon. Test for popcorn.
      IF(KF2A.GT.0)THEN
        MBARY=0
        IF(KFDIQ.GT.10) THEN
          IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
     &         CALL PYNMES(KFDIQ)
          IF(MSTU(121).NE.0) THEN
             MSTU(121)=0
             RETURN
          ENDIF
          MBARY=2
        ENDIF
        KFQOLD=KF1A
        KFQVER=KF2A
        GOTO 130
      ENDIF
 
C.. Separate incoming flavours, curtain flavour consistency check
      KFIN=KFL1
      KFQOLD=KF1A
      KFQPOP=KF1A/10000
      IF(KF1A.GT.10)THEN
         KFIN=-KFL1
         KFL1A=MOD(KF1A/1000,10)
         KFL1B=MOD(KF1A/100,10)
         IF(IRANK.EQ.0)THEN
            QAWT=1D0
            IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
            IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
            KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
         ENDIF
         IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
             MSTU(121)=0
             RETURN
          ENDIF
         KFQOLD=KFL1A+KFL1B-KFQPOP
      ENDIF
 
C...Meson/baryon choice. Set number of mesons if starting a popcorn
C...system.
  110 MBARY=0
      IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
         IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
            MBARY=1
            CALL PYNMES(0)
         ENDIF
      ELSEIF(KF1A.GT.10)THEN
         MBARY=2
         IF(IRANK.EQ.0) CALL PYNMES(KF1A)
         IF(MSTU(121).GT.0) MBARY=-1
      ENDIF
 
C..x->H+q: Choose single vertex quark. Jump to form hadron.
      IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
         KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
         KFL3=ISIGN(KFQVER,-KFIN)
         GOTO 130
      ENDIF
 
C..x->H+qq: (IDW=proper PARF position for diquark weights)
      IDW=160
      IF(MBARY.EQ.1)THEN
         IF(MSTU(121).EQ.0) IDW=150
         SQWT=PARF(IDW+1)
         IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
         KFQPOP=1+INT((2D0+SQWT)*PYR(0))
C..   Shift to s-curtain parameters if needed
         IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
            PARF(194)=PARF(138)*PARF(139)
            PARF(193)=PARJ(8)+PARJ(9)
         ENDIF
      ENDIF
 
C.. x->H+qq: Get vertex quark
      IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
         IDW=MSTU(122)
         MSTU(121)=MSTU(121)-1
         IF(IDW.EQ.170) THEN
            IF(MSTU(121).EQ.0)THEN
               IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
            ELSE
               IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
            ENDIF
         ELSE
            IF(MSTU(121).EQ.0)THEN
               IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
            ELSE
               IPOS=3*5+5*4+MIN(KFQOLD-1,4)
            ENDIF
         ENDIF
         IPOS=200+30*IPOS+1
 
         IMES=-1
         RMES=PYR(0)*PARF(194)
  120    IMES=IMES+1
         RMES=RMES-PARF(IPOS+IMES)
         IF(IMES.EQ.30) THEN
            MSTU(121)=-1
            KF=-111
            RETURN
         ENDIF
         IF(RMES.GT.0D0) GOTO 120
         KMUL=IMES/5
         KFJ=2*KMUL+1
         IF(KMUL.EQ.2) KFJ=10003
         IF(KMUL.EQ.3) KFJ=10001
         IF(KMUL.EQ.4) KFJ=20003
         IF(KMUL.EQ.5) KFJ=5
         IDIAG=0
         KFQVER=MOD(IMES,5)+1
         IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
         IF(KFQVER.GT.3)THEN
            IDIAG=KFQVER-3
            KFQVER=KFQOLD
         ENDIF
      ELSE
         IF(MBARY.EQ.-1) IDW=170
         SQWT=PARF(IDW+2)
         IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
         IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
         KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
         IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
            KFQVER=KFQPOP
            IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
         ENDIF
      ENDIF
 
C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
      KFLDS=3
      IF(KFQPOP.NE.KFQVER)THEN
         SWT=PARF(IDW+7)
         IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
         IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
         IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
      ENDIF
      KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
     &      +10000*KFQPOP
      KFL3=ISIGN(KFDIQ,KFIN)
 
C..x->M+y: flavour for meson.
  130 IF(MBARY.LE.0)THEN
        KFLA=MAX(KFQOLD,KFQVER)
        KFLB=MIN(KFQOLD,KFQVER)
        KFS=ISIGN(1,KFL1)
        IF(KFLA.NE.KFQOLD) KFS=-KFS
C... Form meson, with spin and flavour mixing for diagonal states.
        IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
           IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
           IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
           RETURN
        ENDIF
        IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
        IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
        IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
        IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
          IF(PYR(0).LT.PARJ(14)) KMUL=2
        ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
          RMUL=PYR(0)
          IF(RMUL.LT.PARJ(15)) KMUL=3
          IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
          IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
        ENDIF
        KFLS=3
        IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
        IF(KMUL.EQ.5) KFLS=5
        IF(KFLA.NE.KFLB)THEN
          KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
        ELSE
          RMIX=PYR(0)
          IMIX=2*KFLA+10*KMUL
          IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
     &    INT(RMIX+PARF(IMIX)))+KFLS
          IF(KFLA.GE.4) KF=110*KFLA+KFLS
        ENDIF
        IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
        IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
 
C..Optional extra suppression of eta and eta'.
C..Allow shift to qq->B+q in old version (set IRANK to 0)
        IF(KF.EQ.221.OR.KF.EQ.331)THEN
           IF(PYR(0).GT.PARJ(25+KF/300))THEN
              IF(KF2A.GT.0) GOTO 130
              IF(MSTJ(12).LT.4) IRANK=0
              GOTO 110
           ENDIF
        ENDIF
        MSTU(121)=0
 
C.. x->B+y: Flavour for baryon
      ELSE
        KFLA=KFQVER
        IF(KF1A.LE.10) KFLA=KFQOLD
        KFLB=MOD(KFDIQ/1000,10)
        KFLC=MOD(KFDIQ/100,10)
        KFLDS=MOD(KFDIQ,10)
        KFLD=MAX(KFLA,KFLB,KFLC)
        KFLF=MIN(KFLA,KFLB,KFLC)
        KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
 
C...  SU(6) factors for formation of baryon.
        KBARY=3
        KDMAX=5
        KFLG=KFLB
        IF(KFLB.NE.KFLC)THEN
           KBARY=2*KFLDS-1
           KDMAX=1+KFLDS/2
           IF(KFLB.GT.2) KDMAX=KDMAX+2
        ENDIF
        IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
           KBARY=KBARY+1
           KFLG=KFLA
        ENDIF
 
        SU6MAX=PARF(140+KDMAX)
        SU6DEC=PARJ(18)
        SU6S  =PARF(146)
        IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
           SU6MAX=1D0
           SU6DEC=1D0
           SU6S  =1D0
        ENDIF
        SU6OCT=PARF(60+KBARY)
        IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
           SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
           IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
        ELSE
           IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
        ENDIF
        SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
 
C..   SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
        IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
           MSTU(121)=0
           IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
           GOTO 110
        ENDIF
 
C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
        KSIG=1
        KFLS=2
        IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
        IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
          KSIG=KFLDS/3
          IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
        ENDIF
        KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
        IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
      ENDIF
      RETURN
 
C...Use tabulated probabilities to select new flavour and hadron.
  140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
        KT3L=1
        KT3U=6
      ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
        KT3L=1
        KT3U=6
      ELSEIF(KTAB2.EQ.0) THEN
        KT3L=1
        KT3U=22
      ELSE
        KT3L=KTAB2
        KT3U=KTAB2
      ENDIF
      RFL=0D0
      DO 160 KTS=0,2
        DO 150 KT3=KT3L,KT3U
          RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
  150   CONTINUE
  160 CONTINUE
      RFL=PYR(0)*RFL
      DO 180 KTS=0,2
        KTABS=KTS
        DO 170 KT3=KT3L,KT3U
          KTAB3=KT3
          RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
          IF(RFL.LE.0D0) GOTO 190
  170   CONTINUE
  180 CONTINUE
  190 CONTINUE
 
C...Reconstruct flavour of produced quark/diquark.
      IF(KTAB3.LE.6) THEN
        KFL3A=KTAB3
        KFL3B=0
        KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
      ELSE
        KFL3A=1
        IF(KTAB3.GE.8) KFL3A=2
        IF(KTAB3.GE.11) KFL3A=3
        IF(KTAB3.GE.16) KFL3A=4
        KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
        KFL3=1000*KFL3A+100*KFL3B+1
        IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
     &  KFL3+2
        KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
      ENDIF
 
C...Reconstruct meson code.
      IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
     &KFL3B.NE.0)) THEN
        RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
     &  25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
        KF=110+2*KTABS+1
        IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
        IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
     &  25*KTABS)) KF=330+2*KTABS+1
      ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
        KFLA=MAX(KTAB1,KTAB3)
        KFLB=MIN(KTAB1,KTAB3)
        KFS=ISIGN(1,KFL1)
        IF(KFLA.NE.KF1A) KFS=-KFS
        KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
      ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
        KFS=ISIGN(1,KFL1)
        IF(KFL1A.EQ.KFL3A) THEN
          KFLA=MAX(KFL1B,KFL3B)
          KFLB=MIN(KFL1B,KFL3B)
          IF(KFLA.NE.KFL1B) KFS=-KFS
        ELSEIF(KFL1A.EQ.KFL3B) THEN
          KFLA=KFL3A
          KFLB=KFL1B
          KFS=-KFS
        ELSEIF(KFL1B.EQ.KFL3A) THEN
          KFLA=KFL1A
          KFLB=KFL3B
        ELSEIF(KFL1B.EQ.KFL3B) THEN
          KFLA=MAX(KFL1A,KFL3A)
          KFLB=MIN(KFL1A,KFL3A)
          IF(KFLA.NE.KFL1A) KFS=-KFS
        ELSE
          CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
          GOTO 100
        ENDIF
        KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
 
C...Reconstruct baryon code.
      ELSE
        IF(KTAB1.GE.7) THEN
          KFLA=KFL3A
          KFLB=KFL1A
          KFLC=KFL1B
        ELSE
          KFLA=KFL1A
          KFLB=KFL3A
          KFLC=KFL3B
        ENDIF
        KFLD=MAX(KFLA,KFLB,KFLC)
        KFLF=MIN(KFLA,KFLB,KFLC)
        KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
        IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
        IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
      ENDIF
 
C...Check that constructed flavour code is an allowed one.
      IF(KFL2.NE.0) KFL3=0
      KC=PYCOMP(KF)
      IF(KC.EQ.0) THEN
        CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
     &  'failed')
        GOTO 100
      ENDIF
 
      RETURN
      END

C*********************************************************************
 
C...PYNMES
C...Generates number of popcorn mesons and stores some relevant
C...parameters.
 
      SUBROUTINE PYNMES(KFDIQ)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
      MSTU(121)=0
      IF(MSTJ(12).LT.2) RETURN
 
C..Old version: Get 1 or 0 popcorn mesons
      IF(MSTJ(12).LT.5)THEN
         POPWT=PARF(131)
         IF(KFDIQ.NE.0) THEN
            KFDIQA=IABS(KFDIQ)
            KFA=MOD(KFDIQA/1000,10)
            KFB=MOD(KFDIQA/100,10)
            KFS=MOD(KFDIQA,10)
            POPWT=PARF(132)
            IF(KFA.EQ.3) POPWT=PARF(133)
            IF(KFB.EQ.3) POPWT=PARF(134)
            IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
         ENDIF
         MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
         RETURN
      ENDIF
 
C..New version: Store popcorn- or rank 0 diquark parameters
      MSTU(122)=170
      PARF(193)=PARJ(8)
      PARF(194)=PARF(139)
      IF(KFDIQ.NE.0) THEN
         MSTU(122)=180
         PARF(193)=PARJ(10)
         PARF(194)=PARF(140)
      ENDIF
      IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
         IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
     &        '(PYNMES:) Neglecting too large popcorn possibility')
         RETURN
      ENDIF
 
C..New version: Get number of popcorn mesons
  100 RTST=PYR(0)
      MSTU(121)=-1
  110 MSTU(121)=MSTU(121)+1
      RTST=RTST/PARF(194)
      IF(RTST.LT.1D0) GOTO 110
      IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
     &     (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
      RETURN
      END
  
C***************************************************************

C...PYKFIN
C...Precalculates a set of diquark and popcorn weights.
 
      SUBROUTINE PYKFIN
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
      DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
        
 
      MSTU(123)=1
C..Diquark indices for dimensional variables
      IUD1=1
      IUU1=2
      IUS0=3
      ISU0=4
      IUS1=5
      ISU1=6
      ISS1=7

C.. *** SU(6) factors **
C..Modify with decuplet- (and Sigma/Lambda-) suppression.
      PARF(146)=1D0
      IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
      IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
     &     '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
      DO 100 I=1,6
         SU6(I)=PARF(60+I)
         SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
  100 CONTINUE
      SU6(8)=SU6(2)*4/(3*PARF(146)+1)
      SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
      DO 110 I=1,6
         SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
         SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
  110 CONTINUE
 
C..SU(6)max            q       q'     s,c,b
      SU6MUD    =MAX(SU6(1) ,       SU6(8) )
      SU6M(IUD1)=MAX(SU6(5) ,       SU6(12))
      SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
      SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
      SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
      SU6M(IUS0)=SU6M(ISU0)
      SU6M(ISS1)=SU6M(IUU1)
      SU6M(IUS1)=SU6M(ISU1)
 
C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
      PARF(141)=SU6MUD
      PARF(142)=SU6M(IUD1)
      PARF(143)=SU6M(ISU0)
      PARF(144)=SU6M(ISU1)
      PARF(145)=SU6M(ISS1)

C..diquark SU(6) survival = 
C..sum over quark (quark tunnel weight)*(SU(6)).
      PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
      DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
      DMB(IUS0)=DMB(ISU0)
      DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
      DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
      DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
      DMB(IUS1)=DMB(ISU1)
      DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
 
C.. *** Tunneling factors for Diquark production***
C.. T: half a curtain pair = sqrt(curtain pair factor)
      IF(MSTJ(12).GE.5) THEN
         PMUD0=PYMASS(2101)
         PMUD1=PYMASS(2103)-PMUD0
         PMUS0=PYMASS(3201)-PMUD0
         PMUS1=PYMASS(3203)-PMUS0-PMUD0
         PMSS1=PYMASS(3303)-PMUS0-PMUD0
         QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
         QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
         QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
         QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
         QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
         QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
         QBB(IUD1)=QBB(IUU1)
      ELSE
         PAR2M=SQRT(PARJ(2))
         PAR3M=SQRT(PARJ(3))
         PAR4M=SQRT(PARJ(4))
         QBB(ISU0)=PAR2M*PAR3M
         QBB(IUS0)=PAR3M
         QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
         QBB(IUU1)=PAR4M
         QBB(ISU1)=PAR4M*QBB(ISU0)
         QBB(IUS1)=PAR4M*QBB(IUS0)
         QBB(IUD1)=PAR4M
      ENDIF
 
C.. tau: spin*(vertex factor)*(T = half-curtain factor)
      QBM(ISU0)=QBB(ISU0)
      QBM(IUS0)=PARJ(2)*QBB(IUS0)
      QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
      QBM(IUU1)=6D0*QBB(IUU1)
      QBM(ISU1)=3D0*QBB(ISU1)
      QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
      QBM(IUD1)=3D0*QBB(IUD1)

C.. Combine T and tau to diquark weight for q-> B+B+..
      DO 120 I=1,7
         QBB(I)=QBB(I)*QBM(I)
  120 CONTINUE
  
      IF(MSTJ(12).GE.5)THEN
C..New version: tau  for rank 0 diquark.
         DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
         DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
         DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
         DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
         DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
         DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
         DMB(7+IUD1)=DMB(7+IUU1)/2D0
 
C..New version: curtain flavour ratios.
C.. s/u for q->B+M+...
C.. s/u for rank 0 diquark: su -> ...M+B+...
C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
         WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
         PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
         WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
         PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
         PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
     &        (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
      ELSE
C..Old version: reset unused rank 0 diquark weights and 
C..             unused diquark SU(6) survival weights
         DO 130 I=1,7
            IF(MSTJ(12).LT.3) DMB(I)=1D0
            DMB(7+I)=1D0
 130     CONTINUE

C..Old version: Shuffle PARJ(7) into tau
         QBM(IUS0)=QBM(IUS0)*PARJ(7)
         QBM(ISS1)=QBM(ISS1)*PARJ(7)
         QBM(IUS1)=QBM(IUS1)*PARJ(7)
 
C..Old version: curtain flavour ratios.
C.. s/u for q->B+M+...
C.. s/u for rank 0 diquark: su -> ...M+B+...
C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
         WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
         PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
         PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
         PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
      ENDIF
 
C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
C..  rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
      DO 140 I=1,7
         DMB(7+I)=DMB(7+I)*DMB(I)
         DMB(I)=DMB(I)*QBM(I)
         QBM(I)=QBM(I)*SU6M(I)/SU6MUD
         QBB(I)=QBB(I)*SU6M(I)/SU6MUD
  140 CONTINUE

C.. *** Popcorn factors ***
 
      IF(MSTJ(12).LT.5)THEN
C.. Old version: Resulting popcorn weights.
         PARF(138)=PARJ(6)
         WS=PARF(135)*PARF(138)
         WQ=WU*PARJ(5)/3D0
         PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
         PARF(133)=WQ*
     &        (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
         PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
         PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
     &                 WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
     &        (1D0+QBB(IUD1)+QBB(IUU1)+
     &        2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
      ELSE
C..New version: Store weights for popcorn mesons,
C..get prel. popcorn weights.
         DO 150 IPOS=201,1400
            PARF(IPOS)=0D0
  150    CONTINUE
         DO 160 I=138,140
            PARF(I)=0D0
  160    CONTINUE
         IPOS=200
         PARF(193)=PARJ(8)
         DO 240 MR=0,7,7
           IF(MR.EQ.7) PARF(193)=PARJ(10)
           SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
     &          (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
           QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
           DO 230 NMES=0,1
             IF(NMES.EQ.1) SQWT=PARJ(2)
             DO 220 KFQPOP=1,4
               IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
               IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
                  SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
                  QQWT=0.5D0
                  IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
                  IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
               ENDIF
               DO 210 KFQOLD =1,5
                  IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
                  IF(NMES.EQ.1) THEN
                     IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
                     IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
                  ENDIF
                  WTTOT=0D0
                  WTFAIL=0D0
      DO 190 KMUL=0,5
         PJWT=PARJ(12+KMUL)
         IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
         IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
         IF(PJWT.LE.0D0) GOTO 190
         IF(PJWT.GT.1D0) PJWT=1D0
         IMES=5*KMUL
         IMIX=2*KFQOLD+10*KMUL
         KFJ=2*KMUL+1
         IF(KMUL.EQ.2) KFJ=10003
         IF(KMUL.EQ.3) KFJ=10001
         IF(KMUL.EQ.4) KFJ=20003
         IF(KMUL.EQ.5) KFJ=5
         DO 180 KFQVER =1,3
            KFLA=MAX(KFQOLD,KFQVER)
            KFLB=MIN(KFQOLD,KFQVER)
            SWT=PARJ(11+KFLA/3+KFLA/4)
            IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
            SWT=SWT*PJWT
            QWT=SQWT/(2D0+SQWT)
            IF(KFQVER.LT.3)THEN
               IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
               IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
            ENDIF
            IF(KFQVER.NE.KFQOLD)THEN
               IMES=IMES+1
               KFM=100*KFLA+10*KFLB+KFJ
               PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
               PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
               WTTOT=WTTOT+PARF(IPOS+IMES)
            ELSE
               DO 170 ID=3,5
                  IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
                  IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
                  IF(ID.EQ.5) DWT=PARF(IMIX)
                  KFM=110*(ID-2)+KFJ
                  PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
                  PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
                  IF(KMUL.EQ.0.AND.ID.GT.3) THEN
                     WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
                     PARF(IPOS+5*KMUL+ID)=
     &                    PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
                  ENDIF
                  WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
  170          CONTINUE
            ENDIF
  180    CONTINUE
  190 CONTINUE
                  DO 200 IMES=1,30
                     PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
  200             CONTINUE
                  IF(MR.EQ.7) PARF(140)=
     &                 MAX(PARF(140),WTTOT/(1D0-WTFAIL))
                  IF(MR.EQ.0) PARF(139-KFQPOP/3)=
     &                 MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
                  IPOS=IPOS+30
  210           CONTINUE
  220         CONTINUE
  230       CONTINUE
  240    CONTINUE
         IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
         MSTU(121)=0
 
      ENDIF
 
C..Recombine diquark weights to flavour and spin ratios
      PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
     &        (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
      PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
      PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
      PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
      PARF(155)=QBB(ISU1)/QBB(ISU0)
      PARF(156)=QBB(IUS1)/QBB(IUS0)
      PARF(157)=QBB(IUD1)

      PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
     &        (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
      PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
      PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
      PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
      PARF(165)=QBM(ISU1)/QBM(ISU0)
      PARF(166)=QBM(IUS1)/QBM(IUS0)
      PARF(167)=QBM(IUD1)

      PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
     &        (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
      PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
      PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
      PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
      PARF(175)=DMB(ISU1)/DMB(ISU0)
      PARF(176)=DMB(IUS1)/DMB(IUS0)
      PARF(177)=DMB(IUD1)

      PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
      PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
      PARF(187)=DMB(7+IUD1)

      RETURN
      END
 

C*********************************************************************
 
C...PYPTDI
C...Generates transverse momentum according to a Gaussian.
 
      SUBROUTINE PYPTDI(KFL,PX,PY)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Generate p_T and azimuthal angle, gives p_x and p_y.
      KFLA=IABS(KFL)
      PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
      IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
      IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
      IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
      PHI=PARU(2)*PYR(0)
      PX=PT*COS(PHI)
      PY=PT*SIN(PHI)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYZDIS
C...Generates the longitudinal splitting variable z.
 
      SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Check if heavy flavour fragmentation.
      KFLA=IABS(KFL1)
      KFLB=IABS(KFL2)
      KFLH=KFLA
      IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
 
C...Lund symmetric scaling function: determine parameters of shape.
      IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
     &MSTJ(11).GE.4) THEN
        FA=PARJ(41)
        IF(MSTJ(91).EQ.1) FA=PARJ(43)
        IF(KFLB.GE.10) FA=FA+PARJ(45)
        FBB=PARJ(42)
        IF(MSTJ(91).EQ.1) FBB=PARJ(44)
        FB=FBB*PR
        FC=1D0
        IF(KFLA.GE.10) FC=FC-PARJ(45)
        IF(KFLB.GE.10) FC=FC+PARJ(45)
        IF(MSTJ(11).GE.4.AND.KFLH.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)
      IMPLICIT INTEGER(I-N)
      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),ISSET(3)
 
C...Check that QMAX not too low.
      IF(MSTJ(41).LE.0) THEN
        RETURN
      ELSEIF(MSTJ(41).EQ.1) THEN
        IF(QMAX.LE.PARJ(82).AND.IP2.GT.-5) RETURN
      ELSE
        IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-5) 
     &  RETURN
      ENDIF
 
C...Initialization of cutoff masses etc.
      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))
      PMQT1E=MIN(PMQTH1,PARJ(90))
      PMQTH2=PMTH(2,21)
      IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
      PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
      DO 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(90)**2)
        PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
        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.
      MPSPD=0
      IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
        NPA=1
        IPA(1)=IP1
      ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
     &  MSTU(32))) THEN
        NPA=2
        IPA(1)=IP1
        IPA(2)=IP2
      ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
     &  .AND.IP2.GE.-3) THEN
        NPA=IABS(IP2)
        DO 130 I=1,NPA
          IPA(I)=IP1+I-1
  130   CONTINUE
      ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
     &IP2.EQ.-8) THEN
        MPSPD=1
        NPA=2
        IPA(1)=IP1+6
        IPA(2)=IP1+7  
      ELSE
        CALL PYERRM(12,
     &  '(PYSHOW:) failed to reconstruct showering system')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
 
C...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.AND.IP2.GT.-5) RETURN
      PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
      IF(NPA.EQ.1) PS(5)=PS(4)
      IF(PS(5).LE.PM+PMQT1E) RETURN
 
C...Check if 3-jet matrix elements to be used.
      M3JC=0
      IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) 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
          PQMES=PMTH(1,KFLA(1))**2
          QME=4D0*PQMES/PS(5)**2
          RESCZ=MIN(1D0,LOG(PMTH(2,KFLA(1))/PS(5))/
     &    LOG(PMTH(2,21)/PS(5)))
        ENDIF
      ENDIF
 
C...Find if interference with initial state partons.
      MIIS=0
      IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0) 
     &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
  265 N=NS
      IF(NPA.GE.2) THEN
        K(N+1,1)=11
        K(N+1,2)=21
        K(N+1,3)=0
        K(N+1,4)=0
        K(N+1,5)=0
        P(N+1,1)=0D0
        P(N+1,2)=0D0
        P(N+1,3)=0D0
        P(N+1,4)=PS(5)
        P(N+1,5)=PS(5)
        V(N+1,5)=PS(5)**2
        N=N+1
      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 daughters 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(IP2.LE.-5) P(N+I,5)=MAX(P(N+I,5),
     &    2D0*PMTH(3,IABS(K(N+I,2))))
          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.PMQT2E) 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...Cancel choice of predetermined daughter already treated.
      INUM=MAX(1,INUM)
      INUMT=INUM 
      IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
        IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
      ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
        IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
        IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
      ENDIF
       
C...Store information on choice of evolving daughter.
      IEP(1)=N+INUM
      DO 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...Check if evolution already predetermined for daughter.
      IPSPD=0
      IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
        IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
      ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
        IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
        IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
      ENDIF
      ISSET(INUM)=0
      IF(IPSPD.NE.0) ISSET(INUM)=1  
 
C...Select side for interference with initial state partons.
      IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
        III=IEP(1)-NS-1
        ISII(III)=0
        IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
          ISII(III)=1
        ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
          IF(PYR(0).GT.0.5D0) ISII(III)=1
        ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
          ISII(III)=1
          IF(PYR(0).GT.0.5D0) ISII(III)=2
        ENDIF
      ENDIF
 
C...Calculate allowed z range.
      IF(NEP.EQ.1) THEN
        PMED=PS(4)
      ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
        PMED=P(IM,5)
      ELSE
        IF(INUM.EQ.1) PMED=V(IM,1)*PEM
        IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
      ENDIF
      IF(MOD(MSTJ(43),2).EQ.1) THEN
        ZC=PMTH(2,21)/PMED
        ZCE=PMTH(2,22)/PMED
        IF(KFL(1).GE.11.AND.KFL(1).LE.18) ZCE=0.5D0*PARJ(90)/PMED
      ELSE
        ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
        IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
        PMTMPE=PMTH(2,22)
        IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMTMPE=0.5D0*PARJ(90)
        ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
        IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
      ENDIF
      ZC=MIN(ZC,0.491D0)
      ZCE=MIN(ZCE,0.49991D0)
      IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
     &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
        P(IEP(1),5)=PMTH(1,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
      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
C...Already predetermined choice.
      IF(IPSPD.NE.0) THEN
        PMSQCD=P(IPSPD,5)**2
      ELSEIF(FBR.LT.1D-3) THEN
        PMSQCD=0D0
      ELSEIF(MSTJ(44).LE.0) THEN
        PMSQCD=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.AND.
     &IPSPD.EQ.0) THEN
        PMSQED=PMS*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(101)*FBRE)))
        IF(ZCE.GT.0.4999D0.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...Already predetermined choice of z, and flavour in g -> qqbar.
      IF(IPSPD.NE.0) THEN
        IPSGD1=K(IPSPD,4)
        IPSGD2=K(IPSPD,5)
        PMSGD1=P(IPSGD1,5)**2
        PMSGD2=P(IPSGD2,5)**2
        ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
     &  4D0*PMSGD1*PMSGD2))
        Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
     &  PMSGD1+PMSGD2)/ALAMPS
        Z=MAX(0.00001D0,MIN(0.99999D0,Z))
        IF(KFL(1).NE.21) THEN
          K(IEP(1),5)=21
        ELSE
          K(IEP(1),5)=IABS(K(IPSGD1,2))
        ENDIF
 
C...Select z value of branching: q -> qgamma.
      ELSEIF(MCE.EQ.2) THEN
        Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
        IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 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(IGM.EQ.0.AND.M3JCM.EQ.1) Z=1D0-(1D0-Z)**RESCZ
        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.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=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
        IF(MSTJ(44).LE.2) THEN
          IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) 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
        ELSE
          IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 390
        ENDIF
        K(IEP(1),5)=KFLB
 
C...Ditto for scalar gluon model.
      ELSEIF(KFL(1).NE.21) THEN
        Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
        K(IEP(1),5)=21
      ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
        Z=ZC+(1D0-2D0*ZC)*PYR(0)
        K(IEP(1),5)=21
      ELSE
        Z=ZC+(1D0-2D0*ZC)*PYR(0)
        KFLB=1+INT(MSTJ(45)*PYR(0))
        PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
        IF(PMQ.GE.1D0) GOTO 390
        K(IEP(1),5)=KFLB
      ENDIF

C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
      IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
        IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
          IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 390
        ELSE
          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
      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)
        IF(KFL(1).GE.11.AND.KFL(1).LE.18) PMQTH3=0.5D0*PARJ(90)
        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
      IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.MSTJ(44).EQ.3) THEN
      ELSEIF(IPSPD.NE.0) THEN
      ELSE 
        ZL=0.5D0*(ZH-ZD)
        ZU=0.5D0*(ZH+ZD)
        IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390
      ENDIF
      IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
     &(1D0-ZU)))
      IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
 
C...Width suppression for q -> q + g.
      IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
        IF(IGM.EQ.0) THEN
          EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
        ELSE
          EGLU=PMED*(1D0-Z)
        ENDIF
        CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
        IF(MSTJ(40).EQ.1) THEN
          IF(CHI.LT.PYR(0)) GOTO 390
        ELSEIF(MSTJ(40).EQ.2) THEN
          IF(1D0-CHI.LT.PYR(0)) GOTO 390
        ENDIF
      ENDIF
 
C...Three-jet matrix element correction (on both sides).
      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.AND.M3JCM.NE.1) THEN
          WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+
     &    (1D0-X2)/X3*(X2/(2D0-X1))**2
          WME=X1**2+X2**2
        ELSEIF(MSTJ(49).NE.1) THEN
          X1=(1D0+(V(IEP(1),5)-PQMES)/V(NS+1,5))*
     &    (Z+(1D0-Z)*PQMES/V(IEP(1),5))
          X2=1D0-(V(IEP(1),5)-PQMES)/V(NS+1,5)
          X3=(1D0-X1)+(1D0-X2)
          Z1SH=(X1-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X2)))/(2D0-X2)
          Z2SH=(X2-(PQMES/V(NS+1,5))*(X3/MAX(1D-10,1D0-X1)))/(2D0-X1)
          WSHOW=(((1D0-X1)/(2D0-X2))*(1D0+Z1SH**2)/MAX(1D-10,1D0-Z1SH)+
     &    ((1D0-X2)/(2D0-X1))*(1D0+Z2SH**2)/MAX(1D-10,1D0-Z2SH))/RESCZ
          WME=X1**2+X2**2-QME*X3-0.5D0*QME**2-
     &    (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-10,1D0-X1)+
     &    (1D0-X1)/MAX(1D-10,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.AND.IPSPD.EQ.0) 
     &THEN
        PEMAO=V(IM,1)*P(IM,4)
        IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
        IF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.4) THEN
          MAOD=0
        ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.MSTJ(42).EQ.3) 
     &  THEN
          MAOD=1
          PMDAO=PMTH(2,K(IEP(1),5))
          THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
        ELSE
          MAOD=1
          THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
        ENDIF
        MAOM=1
        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.AND.MAOD.EQ.1) THEN
          THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
          IF(THE2ID.LT.THE2IM) GOTO 390
        ENDIF
      ENDIF
 
C...Impose user-defined maximum angle at first branching.
      IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
        IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
          THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
          IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 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(PARJ(85)**2*THE2ID.LT.1D0) 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(PARJ(86)**2*THE2ID.LT.1D0) 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)
            IF(KFLDA.GE.11.AND.KFLDA.LE.18) PMQTH3=0.5D0*PARJ(90)
            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
          IF(KFLDA.EQ.21.AND.KFLGD1.LT.10.AND.MSTJ(44).EQ.3) THEN
          ELSE 
            ZL=0.5D0*(ZH-ZD)
            ZU=0.5D0*(ZH+ZD)
            IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
     &      ISSET(1).EQ.0) THEN
              ISL(1)=1
            ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
     &      ISSET(2).EQ.0) THEN 
              ISL(2)=1
            ENDIF
          ENDIF
          IF(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) THEN
        IF(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
      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)
        LOOPPT=0
  465   LOOPPT=LOOPPT+1
        PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
        PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
        IF(PZM.LE.0D0) THEN
          PTS=0D0
        ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
     &  MSTJ(44).EQ.3) THEN
          PTS=PMLS*ZM*(1D0-ZM)/V(IM,5) 
        ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
          PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
     &    ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
        ELSE
          PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
        ENDIF
        IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
          ZM=0.05D0+0.9D0*ZM
          GOTO 465
        ELSEIF(PTS.LT.0D0) THEN 
          GOTO 265
        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 energies for ordinary branching in shower.
  470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
        IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
     &  MSTJ(44).EQ.3) THEN
          P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
     &    PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
        ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
          P(N+1,4)=PEM*V(IM,1)
        ELSE
          P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
     &    SQRT(PMLS)*ZM)/V(IM,5)
        ENDIF

C...Already predetermined choice of phi angle or not
        PHI=PARU(2)*PYR(0)
        IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
          IPSPD=IP1+IM-NS-2
          IF(K(IPSPD,4).GT.0) THEN
            IPSGD1=K(IPSPD,4)
            IF(IM.EQ.NS+2) THEN
              PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
            ELSE
              PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
            ENDIF
          ENDIF
        ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
          IPSPD=IP1+IM-NS-2
          IF(K(IPSPD,4).GT.0) THEN
            IPSGD1=K(IPSPD,4)
            PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
            THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
            CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
            CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
            PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
            CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)   
          ENDIF
        ENDIF

C...Construct momenta for ordinary branching in shower.
        P(N+1,1)=PT*COS(PHI)
        P(N+1,2)=PT*SIN(PHI)
        IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
     &  MSTJ(44).EQ.3) THEN
          P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
     &    PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
        ELSEIF(PZM.GT.0D0) THEN
          P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
     &    2D0*PEM*P(N+1,4))/PZM
        ELSE
          P(N+1,3)=0D0
        ENDIF
        P(N+2,1)=-P(N+1,1)
        P(N+2,2)=-P(N+1,2)
        P(N+2,3)=PZM-P(N+1,3)
        P(N+2,4)=PEM-P(N+1,4)
        IF(MSTJ(43).LE.2) THEN
          V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
          V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
        ENDIF
      ENDIF
 
C...Rotate and boost daughters.
      IF(IGM.GT.0) THEN
        IF(MSTJ(43).LE.2) THEN
          BEX=P(IGM,1)/P(IGM,4)
          BEY=P(IGM,2)/P(IGM,4)
          BEZ=P(IGM,3)/P(IGM,4)
          GA=P(IGM,4)/P(IGM,5)
          GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
     &    P(IM,4))
        ELSE
          BEX=0D0
          BEY=0D0
          BEZ=0D0
          GA=1D0
          GABEP=0D0
        ENDIF
        PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
        THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
        IF(PTIMB.GT.1D-4) THEN
          PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
        ELSE
          PHI=0D0
        ENDIF 
        DO 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)/MAX(1D-10,DPMM)
          DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,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.LE.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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
      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)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
C...Local arrays and data.
      DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
     &BEIW(100),BEI3W(100)
      DATA KFBE/211,-211,111,321,-321,130,310,221,331/
C...Statement function: squared invariant mass.
      SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
     &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
 
C...Boost event to overall CM frame. Calculate CM energy.
      IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
      DO 100 J=1,4
        DPS(J)=0D0
  100 CONTINUE
      DO 120 I=1,N
        KFA=IABS(K(I,2))
        IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
     &  .AND.K(I,3).GT.0) THEN
          KFMA=IABS(K(K(I,3),2))
          IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
        ENDIF
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
        DO 110 J=1,4
          DPS(J)=DPS(J)+P(I,J)
  110   CONTINUE
  120 CONTINUE
      CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
     &-DPS(3)/DPS(4))
      PECM=0D0
      DO 130 I=1,N
        IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
  130 CONTINUE
 
C...Reserve copy of particles by species at end of record.
      IWP=0
      IWN=0
      NBE(0)=N+MSTU(3)
      NMAX=NBE(0)
      SMMIN=PECM
      DO 180 IBE=1,MIN(10,MSTJ(52)+1)
        NBE(IBE)=NBE(IBE-1)
        DO 170 I=NSAV+1,N
          IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
            DO 140 IIBE=1,IBE-1
              IF(K(I,2).EQ.KFBE(IIBE)) GOTO 170
  140       CONTINUE
          ELSE
            IF(K(I,2).NE.KFBE(IBE)) GOTO 170
          ENDIF
          IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
          IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
            CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
            RETURN
          ENDIF
          NBE(IBE)=NBE(IBE)+1
          NMAX=NBE(IBE)
          K(NBE(IBE),1)=I
          K(NBE(IBE),5)=0
          SMMIN=MIN(SMMIN,P(I,5))
          IF(MSTJ(53).NE.0.OR.MSTJ(56).GT.0) THEN
            IM=I
  150       IF(K(IM,3).GT.0) THEN
              IM=K(IM,3)
              IF(ABS(K(IM,2)).NE.24) GOTO 150
              K(NBE(IBE),5)=K(IM,2)
              IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
              IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
            ENDIF
          ENDIF
          DO 160 J=1,3
            P(NBE(IBE),J)=0D0
            V(NBE(IBE),J)=0D0
  160     CONTINUE
          P(NBE(IBE),5)=-1.0D0
  170   CONTINUE
  180 CONTINUE
      IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 500
 
C...Calculate separation between W+ and W-
      SIGW=PARJ(93)
      IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0) THEN
        DMW=PMAS(24,1)
        DGW=PMAS(24,2)
        DMP=P(IWP,5)
        DMN=P(IWN,5)
        TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
        TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
        TAUP=-TAUPD*LOG(PYR(IDUM))
        TAUN=-TAUND*LOG(PYR(IDUM))
        DXP=TAUP*PYP(IWP,8)/DMP
        DXN=TAUN*PYP(IWN,8)/DMN
        DX=DXP+DXN
        SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
      ELSE
        SIGW=PARJ(93)
      ENDIF
 
      IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
        DO 210 IBE=1,MIN(9,MSTJ(52))
          DO 200 I1M=NBE(IBE-1)+1,NBE(IBE)-1
            Q2MIN=PECM**2
            I1=K(I1M,1)
            DO 190 I2M=NBE(IBE-1)+1,NBE(IBE)-1
              IF(I2M.EQ.I1M) GOTO 190
              I2=K(I2M,1)
              Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
     &        (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
     &        (P(I1,5)+P(I2,5))**2
              IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
                Q2MIN=Q2
              ENDIF
  190       CONTINUE
            P(I1M,5)=Q2MIN
  200     CONTINUE
  210   CONTINUE
      ENDIF
 
C...Tabulate integral for subsequent momentum shift.
      DO 390 IBE=1,MIN(9,MSTJ(52))
        IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 260
        IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
     &  .LE.1) GOTO 260
        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 260
        IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 260
        IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
        IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
        IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
        IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
        QDEL=0.1D0*MIN(PMHQ,PARJ(93))
        QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
        QDELW=0.1D0*MIN(PMHQ,SIGW)
        QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
        IF(MSTJ(51).EQ.1) THEN
          NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
          NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
          NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
          NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
          BEEX=EXP(0.5D0*QDEL/PARJ(93))
          BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
          BEEXW=EXP(0.5D0*QDELW/SIGW)
          BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
          BERT=EXP(-QDEL/PARJ(93))
          BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
          BERTW=EXP(-QDELW/SIGW)
          BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
        ELSE
          NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
          NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
          NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
          NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
        ENDIF
        DO 220 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)
  220   CONTINUE
        DO 230 IBIN=1,NBIN3
          QBIN=QDEL3*(IBIN-0.5D0)
          BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
          IF(MSTJ(51).EQ.1) THEN
            BEEX3=BEEX3*BERT3
            BEI3(IBIN)=BEI3(IBIN)*BEEX3
          ELSE
            BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
          ENDIF
          IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
  230   CONTINUE
        DO 240 IBIN=1,NBINW
          QBIN=QDELW*(IBIN-0.5D0)
          BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
          IF(MSTJ(51).EQ.1) THEN
            BEEXW=BEEXW*BERTW
            BEIW(IBIN)=BEIW(IBIN)*BEEXW
          ELSE
            BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
          ENDIF
          IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
  240   CONTINUE
        DO 250 IBIN=1,NBIN3W
          QBIN=QDEL3W*(IBIN-0.5D0)
          BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
     &    SQRT(QBIN**2+PMHQ**2)
          IF(MSTJ(51).EQ.1) THEN
            BEEX3W=BEEX3W*BERT3W
            BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
          ELSE
            BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
          ENDIF
          IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
  250   CONTINUE
 
C...Loop through particle pairs and find old relative momentum.
  260   DO 380 I1M=NBE(IBE-1)+1,NBE(IBE)-1
          I1=K(I1M,1)
          DO 370 I2M=I1M+1,NBE(IBE)
            IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 370
            IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 370
            I2=K(I2M,1)
            Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
     &      P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
            IF(Q2OLD.LE.0.0D0) GOTO 370
            QOLD=SQRT(Q2OLD)
 
C...Calculate new relative momentum.
            QMOV=0.0D0
            QMOV3=0.0D0
            QMOVW=0.0D0
            QMOV3W=0.0D0
            IF(QOLD.LT.1D-3*QDEL) THEN
              GOTO 270
            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
  270       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
            IF(QOLD.LT.1D-3*QDEL3) THEN
              GOTO 280
            ELSEIF(QOLD.LE.QDEL3) THEN
              QMOV3=QOLD/3D0
            ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
              RBIN3=QOLD/QDEL3
              IBIN3=RBIN3
              RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
              QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
     &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ELSE
              QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ENDIF
  280       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
            RSCALE=1.0D0
            IF(MSTJ(54).EQ.2)
     &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
            IF(MSTJ(56).LE.0.OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
     &      K(I1M,5).EQ.K(I2M,5)) GOTO 310
 
            IF(QOLD.LT.1D-3*QDELW) THEN
              GOTO 290
            ELSEIF(QOLD.LE.QDELW) THEN
              QMOVW=QOLD/3D0
            ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
              RBINW=QOLD/QDELW
              IBINW=RBINW
              RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
              QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
     &        SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ELSE
              QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ENDIF
  290       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
            IF(QOLD.LT.1D-3*QDEL3W) THEN
              GOTO 300
            ELSEIF(QOLD.LE.QDEL3W) THEN
              QMOV3W=QOLD/3D0
            ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
              RBIN3W=QOLD/QDEL3W
              IBIN3W=RBIN3W
              RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
              QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
     &        BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ELSE
              QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
            ENDIF
  300       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
            IF(MSTJ(54).EQ.2)
     &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
 
  310       CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
            DO 320 J=1,3
              P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
              P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
  320       CONTINUE
            IF(MSTJ(54).GE.1) THEN
              CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
              DO 330 J=1,3
                V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
                V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
  330         CONTINUE
            ELSEIF(MSTJ(54).LE.-1) THEN
              EDEL=P(I1,4)+P(I2,4)-
     &        SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
              A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
     &        (P(I1,3)-P(I2,3))**2
              WMAX=-1.0D20
              MI3=0
              MI4=0
              S12=SDIP(I1,I2)
              SM1=(P(I1,5)+SMMIN)**2
              DO 350 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
                IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 350
                IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 350
                IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
     &          K(I3M,5).NE.K(I1M,5)) GOTO 350
                I3=K(I3M,1)
                IF(K(I3,2).EQ.K(I1,2)) GOTO 350
                S13=SDIP(I1,I3)
                S23=SDIP(I2,I3)
                SM3=(P(I3,5)+SMMIN)**2
                IF(MSTJ(54).EQ.-2) THEN
                  WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
     &            S23*MIN(SM1,SM3))*SM1)
                ELSE
                  WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
     &            (P(I1,3)+P(I2,3)+P(I3,3))**2-
     &            (P(I1,2)+P(I2,2)+P(I3,2))**2-
     &            (P(I1,1)+P(I2,1)+P(I3,1))**2)
                ENDIF
                IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
                  IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
     &                 GOTO 350
                ELSE
                  IF(WMAX*WI.GE.1.0) GOTO 350
                ENDIF
                DO 340 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
                  IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 340
                  IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 340
                  IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
     &            K(I4M,5).NE.K(I1M,5)) GOTO 340
                  I4=K(I4M,1)
                  IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
     &            GOTO 340
                  IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
     &            (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
     &            (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
     &            GOTO 340
                  IF(MSTJ(54).EQ.-2) THEN
                    S14=SDIP(I1,I4)
                    S24=SDIP(I2,I4)
                    S34=SDIP(I3,I4)
                    W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
                    W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
                    W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
                    W=MIN(W,MIN(S23,S24)*S13*S14)
                    W=1.0D0/W
                  ELSE
C...weight=1-cos(theta)/mtot2
                    S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
     &              (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
     &              (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
     &              (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
                    W=1.0D0/S1234
                    IF(W.LE.WMAX) GOTO 340
                  ENDIF
                  IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
     &            W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
                  IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
     &            W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
                  IF(W.LE.WMAX) GOTO 340
                  MI3=I3M
                  MI4=I4M
                  WMAX=W
  340           CONTINUE
  350         CONTINUE
              IF(MI4.EQ.0) GOTO 370
              I3=K(MI3,1)
              I4=K(MI4,1)
              EOLD=P(I3,4)+P(I4,4)
              ENEW=EOLD+EDEL
              P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
     &        (P(I3,3)+P(I4,3))**2
              Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
              Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
              CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
              DO 360 J=1,3
                V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
                V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
  360         CONTINUE
            ENDIF
  370     CONTINUE
  380   CONTINUE
  390 CONTINUE
 
C...Shift momenta and recalculate energies.
      ESUMP=0.0D0
      ESUM=0.0D0
      PROD=0.0D0
      DO 420 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
        I=K(IM,1)
        ESUMP=ESUMP+P(I,4)
        DO 400 J=1,3
          P(I,J)=P(I,J)+P(IM,J)
  400   CONTINUE
        P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
        ESUM=ESUM+P(I,4)
        DO 410 J=1,3
          PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
  410   CONTINUE
  420 CONTINUE
 
      PARJ(96)=0.0D0
      IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
  430   ALPHA=(ESUMP-ESUM)/PROD
        PARJ(96)=PARJ(96)+ALPHA
        PROD=0.0D0
        ESUM=0.0D0
        DO 460 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
          I=K(IM,1)
          DO 440 J=1,3
            P(I,J)=P(I,J)+ALPHA*V(IM,J)
  440     CONTINUE
          P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
          ESUM=ESUM+P(I,4)
          DO 450 J=1,3
            PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
  450     CONTINUE
  460   CONTINUE
        IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
     &  GOTO 430
      ENDIF
 
C...Rescale all momenta for energy conservation.
      PES=0D0
      PQS=0D0
      DO 470 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 470
        PES=PES+P(I,4)
        PQS=PQS+P(I,5)**2/P(I,4)
  470 CONTINUE
      PARJ(95)=PES-PECM
      FAC=(PECM-PQS)/(PES-PQS)
      DO 490 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 490
        DO 480 J=1,3
          P(I,J)=FAC*P(I,J)
  480   CONTINUE
        P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
  490 CONTINUE
 
C...Boost back to correct reference frame.
  500 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
      DO 510 I=1,N
        IF(K(I,1).LT.0) K(I,1)=-K(I,1)
  510 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYBESQ
C...Calculates the momentum shift in a system of two particles assuming
C...the relative momentum squared should be shifted to Q2NEW. NI is the
C...last position occupied in /PYJETS/.
 
      SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
      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)
      SAVE /PYJETS/,/PYDAT1/
C...Local arrays and data.
      DIMENSION DP(5)
      SAVE HC1
 
      IF(MSTJ(55).EQ.0) THEN
        DQ2=Q2NEW-Q2OLD
        DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
     &  (P(I1,3)-P(I2,3))**2
        DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
     &  -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
        SE=P(I1,4)+P(I2,4)
        DE=P(I1,4)-P(I2,4)
        DQ2SE=DQ2+SE**2
        DA=SE*DE*DP12-DP2*DQ2SE
        DB=DP2*DQ2SE-DP12**2
        HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
        DO 100 J=1,3
          PD=HA*(P(I1,J)-P(I2,J))
          P(NI+1,J)=PD
          P(NI+2,J)=-PD
  100   CONTINUE
        RETURN
      ENDIF
 
      K(NI+1,1)=1
      K(NI+2,1)=1
      DO 110 J=1,5
        P(NI+1,J)=P(I1,J)
        P(NI+2,J)=P(I2,J)
        DP(J)=P(I1,J)+P(I2,J)
  110 CONTINUE
 
C...Boost to cms and rotate first particle to z-axis
      CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
     &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
      PHI=PYANGL(P(NI+1,1),P(NI+1,2))
      THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
      S=Q2NEW+(P(I1,5)+P(I2,5))**2
      PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
      P(NI+1,1)=0.0D0
      P(NI+1,2)=0.0D0
      P(NI+1,3)=PZ
      P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
      P(NI+2,1)=0.0D0
      P(NI+2,2)=0.0D0
      P(NI+2,3)=-PZ
      P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
      DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
      CALL PYROBO(NI+1,NI+2,THE,PHI,
     &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
 
      DO 120 J=1,3
        P(NI+1,J)=P(NI+1,J)-P(I1,J)
        P(NI+2,J)=P(NI+2,J)-P(I2,J)
  120 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMASS
C...Gives the mass of a particle/parton.
 
      FUNCTION PYMASS(KF)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Reset variables. Compressed code. Special case for popcorn diquarks.
      PYMASS=0D0
      KFA=IABS(KF)
      KC=PYCOMP(KF)
      IF(KC.EQ.0) THEN
        MSTJ(93)=0
        RETURN
      ENDIF
 
C...Guarantee use of constituent masses for internal checks.
      IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
     &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
        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...PYMRUN
C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
C...for Higgs couplings. Everything else sent on to PYMASS.
 
      FUNCTION PYMRUN(KF,Q2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
 
C...Most masses not handled here.
      KFA=IABS(KF)
      IF(KFA.EQ.0.OR.KFA.GT.5) THEN
        PYMRUN=PYMASS(KF)

C...Current-algebra masses, but no Q2 dependence.
      ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
        PYMRUN=PARF(90+KFA)

C...Running current-algebra masses.
      ELSE
        AS=PYALPS(Q2)
        PYMRUN=PARF(90+KFA)*
     &  (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
     &  LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
      ENDIF

      RETURN
      END
 
C*********************************************************************
 
C...PYNAME
C...Gives the particle/parton name as a character string.
 
      SUBROUTINE PYNAME(KF,CHAU)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT4/CHAF(500,2)
      CHARACTER CHAF*16
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
C...Local character variable.
      CHARACTER CHAU*16
 
C...Read out code with distinction particle/antiparticle.
      CHAU=' '
      KC=PYCOMP(KF)
      IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
 
 
      RETURN
      END
 
C*********************************************************************
 
C...PYCHGE
C...Gives three times the charge for a particle/parton.
 
      FUNCTION PYCHGE(KF)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT2/
 
C...Read out charge and change sign for antiparticle.
      PYCHGE=0
      KC=PYCOMP(KF)
      IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYCOMP
C...Compress the standard KF codes for use in mass and decay arrays;
C...also checks whether a given code actually is defined.
 
      FUNCTION PYCOMP(KF)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
C...Local arrays and saved data.
      DIMENSION KFORD(100:500),KCORD(101:500)
      SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
 
C...Whenever necessary reorder codes for faster search.
      IF(MSTU(20).EQ.0) THEN
        NFORD=100
        KFORD(100)=0
        DO 120 I=101,500
          KFA=KCHG(I,4)
          IF(KFA.LE.100) GOTO 120
          NFORD=NFORD+1
          DO 100 I1=NFORD-1,0,-1
            IF(KFA.GE.KFORD(I1)) GOTO 110
            KFORD(I1+1)=KFORD(I1)
            KCORD(I1+1)=KCORD(I1)
  100     CONTINUE
  110     KFORD(I1+1)=KFA
          KCORD(I1+1)=I
  120   CONTINUE
        MSTU(20)=1
        KFLAST=0
        KCLAST=0
      ENDIF
 
C...Fast action if same code as in latest call.
      IF(KF.EQ.KFLAST) THEN
        PYCOMP=KCLAST
        RETURN
      ENDIF
 
C...Starting values. Remove internal diquark flags.
      PYCOMP=0
      KFA=IABS(KF)
      IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
     &     .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
 
C...Simple cases: direct translation.
      IF(KFA.GT.KFORD(NFORD)) THEN
      ELSEIF(KFA.LE.100) THEN
        PYCOMP=KFA
 
C...Else binary search.
      ELSE
        IMIN=100
        IMAX=NFORD+1
  130   IAVG=(IMIN+IMAX)/2
        IF(KFORD(IAVG).GT.KFA) THEN
          IMAX=IAVG
          IF(IMAX.GT.IMIN+1) GOTO 130
        ELSEIF(KFORD(IAVG).LT.KFA) THEN
          IMIN=IAVG
          IF(IMAX.GT.IMIN+1) GOTO 130
        ELSE
          PYCOMP=KCORD(IAVG)
        ENDIF
      ENDIF
 
C...Check if antiparticle allowed.
      IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
        IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
      ENDIF
 
C...Save codes for possible future fast action.
      KFLAST=KF
      KCLAST=PYCOMP
 
      RETURN
      END
 
C*********************************************************************
 
C...PYERRM
C...Informs user of errors in program execution.
 
      SUBROUTINE PYERRM(MERR,CHMESS)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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),5200)
          IF(MERR.NE.17) CALL PYLIST(2)
          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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Calculate real part of photon vacuum polarization.
C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
C...For hadrons use parametrization of H. Burkhardt et al.
C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
      AEMPI=PARU(101)/(3D0*PARU(1))
      IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
        RPIGG=0D0
      ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
        RPIGG=0D0
      ELSEIF(MSTU(101).EQ.2) THEN
        RPIGG=1D0-PARU(101)/PARU(103)
      ELSEIF(Q2.LT.0.09D0) THEN
        RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
      ELSEIF(Q2.LT.9D0) THEN
        RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
     &  0.00238D0*LOG(1D0+3.927D0*Q2)
      ELSEIF(Q2.LT.1D4) THEN
        RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
     &  0.00299D0*LOG(1D0+Q2)
      ELSE
        RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
     &  0.00293D0*LOG(1D0+Q2)
      ENDIF
 
C...Calculate running alpha_em.
      PYALEM=PARU(101)/(1D0-RPIGG)
      PARU(108)=PYALEM
 
      RETURN
      END
 
C*********************************************************************
 
C...PYALPS
C...Gives the value of alpha_strong.
 
      FUNCTION PYALPS(Q2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Constant alpha_strong trivial. Pick artificial Lambda.
      IF(MSTU(111).LE.0) THEN
        PYALPS=PARU(111)
        MSTU(118)=MSTU(112)
        PARU(117)=0.2D0
        IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
     &  ((33D0-2D0*MSTU(112))*PARU(111)))
        PARU(118)=PARU(111)
        RETURN
      ENDIF
 
C...Find effective Q2, number of flavours and Lambda.
      Q2EFF=Q2
      IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
      NF=MSTU(112)
      ALAM2=PARU(112)**2
  100 IF(NF.GT.MAX(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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
      PYANGL=0D0
      R=SQRT(X**2+Y**2)
      IF(R.LT.1D-20) RETURN
      IF(ABS(X)/R.LT.0.8D0) THEN
        PYANGL=SIGN(ACOS(X/R),Y)
      ELSE
        PYANGL=ASIN(Y/R)
        IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
          PYANGL=PARU(1)-PYANGL
        ELSEIF(X.LT.0D0) THEN
          PYANGL=-PARU(1)-PYANGL
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYR
C...Generates random numbers uniformly distributed between
C...0 and 1, excluding the endpoints.
 
      FUNCTION PYR(IDUMMY)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDATR/MRPY(6),RRPY(100)
      SAVE /PYDATR/
C...Equivalence between commonblock and local variables.
      EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
     &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
     &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
 
C...Initialize generation from given seed.
      IF(MRPY2.EQ.0) THEN
        IJ=MOD(MRPY1/30082,31329)
        KL=MOD(MRPY1,30082)
        I=MOD(IJ/177,177)+2
        J=MOD(IJ,177)+2
        K=MOD(KL/169,178)+1
        L=MOD(KL,169)
        DO 110 II=1,97
          S=0D0
          T=0.5D0
          DO 100 JJ=1,48
            M=MOD(MOD(I*J,179)*K,179)
            I=J
            J=K
            K=M
            L=MOD(53*L+1,169)
            IF(MOD(L*M,64).GE.32) S=S+T
            T=0.5D0*T
  100     CONTINUE
          RRPY(II)=S
  110   CONTINUE
        TWOM24=1D0
        DO 120 I24=1,24
          TWOM24=0.5D0*TWOM24
  120   CONTINUE
        RRPY98=362436D0*TWOM24
        RRPY99=7654321D0*TWOM24
        RRPY00=16777213D0*TWOM24
        MRPY2=1
        MRPY3=0
        MRPY4=97
        MRPY5=33
      ENDIF
 
C...Generate next random number.
  130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
      IF(RUNI.LT.0D0) RUNI=RUNI+1D0
      RRPY(MRPY4)=RUNI
      MRPY4=MRPY4-1
      IF(MRPY4.EQ.0) MRPY4=97
      MRPY5=MRPY5-1
      IF(MRPY5.EQ.0) MRPY5=97
      RRPY98=RRPY98-RRPY99
      IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
      RUNI=RUNI-RRPY98
      IF(RUNI.LT.0D0) RUNI=RUNI+1D0
      IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
 
C...Update counters. Random number to output.
      MRPY3=MRPY3+1
      IF(MRPY3.EQ.1000000000) THEN
        MRPY2=MRPY2+1
        MRPY3=0
      ENDIF
      PYR=RUNI
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRGET
C...Dumps the state of the random number generator on a file
C...for subsequent startup from this state onwards.
 
      SUBROUTINE PYRGET(LFN,MOVE)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDATR/MRPY(6),RRPY(100)
      SAVE /PYDATR/
C...Local character variable.
      CHARACTER CHERR*8
 
C...Backspace required number of records (or as many as there are).
      IF(MOVE.LT.0) THEN
        NBCK=MIN(MRPY(6),-MOVE)
        DO 100 IBCK=1,NBCK
          BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
  100   CONTINUE
        MRPY(6)=MRPY(6)-NBCK
      ENDIF
 
C...Unformatted write on unit LFN.
      WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
     &(RRPY(I2),I2=1,100)
      MRPY(6)=MRPY(6)+1
      RETURN
 
C...Write error.
  110 WRITE(CHERR,'(I8)') IERR
      CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
     &CHERR)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRSET
C...Reads a state of the random number generator from a file
C...for subsequent generation from this state onwards.
 
      SUBROUTINE PYRSET(LFN,MOVE)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDATR/MRPY(6),RRPY(100)
      SAVE /PYDATR/
C...Local character variable.
      CHARACTER CHERR*8
 
C...Backspace required number of records (or as many as there are).
      IF(MOVE.LT.0) THEN
        NBCK=MIN(MRPY(6),-MOVE)
        DO 100 IBCK=1,NBCK
          BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
  100   CONTINUE
        MRPY(6)=MRPY(6)-NBCK
      ENDIF
 
C...Unformatted read from unit LFN.
      NFOR=1+MAX(0,MOVE)
      DO 110 IFOR=1,NFOR
        READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
     &  (RRPY(I2),I2=1,100)
  110 CONTINUE
      MRPY(6)=MRPY(6)+NFOR
      RETURN
 
C...Write error.
  120 WRITE(CHERR,'(I8)') IERR
      CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
     &CHERR)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYROBO
C...Performs rotations and boosts.
 
      SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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 (2000)   '/
      DATA (REFER(J),J=1,18)/
     &'An archive of program versions and d',
     &'ocumentation is found on the web:   ',
     &'http://www.thep.lu.se/~torbjorn/Pyth',
     &'ia.html                             ',
     &'                                    ',
     &'                                    ',
     &'When you cite this program, currentl',
     &'y the official reference is         ',
     &'T. Sjostrand, Computer Physics Commu',
     &'n. 82 (1994) 74.                    ',
     &'The supersymmetry extensions are des',
     &'cribed in                           ',
     &'S. Mrenna, Computer Physics Commun. ',
     &'101 (1997) 232                      ',
     &'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, Physics',
     &' Department, UC Davis,              ',
     &'  One Shields Avenue, Davis, CA 9561',
     &'6, USA;                       ',
     &'  phone: + 1 - 530 - 752 - 2661; e-m',
     &'ail: mrenna@physics.ucdavis.edu     '/
 
C...Check that PYDATA linked.
      IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
        WRITE(*,'(1X,A)')
     &  'Error: PYDATA has not been linked.'
        WRITE(*,'(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.
        WRITE(MSTU(11),'(A79)') LINE
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYUPDA
C...Facilitates the updating of particle and decay data
C...by allowing it to be done in an external file.
 
      SUBROUTINE PYUPDA(MUPDA,LFN)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(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.AND.MDCY(KCREP,3).GT.0) THEN
              IDCREP=MDCY(KCREP,2)
              NDCREP=MDCY(KCREP,3)
              DO 160 I=1,KCC
                IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
  160         CONTINUE
              DO 180 I=IDCREP,NDC-NDCREP
                MDME(I,1)=MDME(I+NDCREP,1)
                MDME(I,2)=MDME(I+NDCREP,2)
                BRAT(I)=BRAT(I+NDCREP)
                DO 170 J=1,5
                  KFDP(I,J)=KFDP(I+NDCREP,J)
  170           CONTINUE
  180         CONTINUE
              NDC=NDC-NDCREP
              KC=KCREP
            ELSEIF(KCREP.NE.0) THEN
              KC=KCREP
            ELSE
              KCC=KCC+1
              KC=KCC
            ENDIF
          ENDIF
 
C...Study line with particle data.
          IF(KC.GT.MSTU(6)) CALL PYERRM(27,
     &    '(PYUPDA:) Particle arrays full by KF ='//CHKF)
          READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
     &    (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
     &    MWID(KC),MDCY(KC,1)
          MDCY(KC,2)=0
          MDCY(KC,3)=0
 
C...Study line with decay data.
        ELSE
          NDC=NDC+1
          IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
     &    '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
          IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
          MDCY(KC,3)=MDCY(KC,3)+1
          READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
     &    (KFDP(NDC,J),J=1,5)
        ENDIF
 
C...End of loop; ensure that PYCOMP tables are updated.
        GOTO 140
  190   CONTINUE
        MSTU(20)=0
 
C...Perform possible tests that new information is consistent.
        DO 220 KC=1,MSTU(6)
          KF=KCHG(KC,4)
          IF(KF.EQ.0) GOTO 220
          WRITE(CHKF,5300) KF
          IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
     &    PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
     &    '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
          BRSUM=0D0
          DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
            IF(MDME(IDC,2).GT.80) GOTO 210
            KQ=KCHG(KC,1)
            PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
            MERR=0
            DO 200 J=1,5
              KP=KFDP(IDC,J)
              IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
                IF(KP.EQ.81) KQ=0
              ELSEIF(PYCOMP(KP).EQ.0) THEN
                MERR=3
              ELSE
                KQ=KQ-PYCHGE(KP)
                KPC=PYCOMP(KP)
                PMS=PMS-PMAS(KPC,1)
                IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
     &          PMAS(KPC,3))
              ENDIF
  200       CONTINUE
            IF(KQ.NE.0) MERR=MAX(2,MERR)
            IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
     &      MERR=MAX(1,MERR)
            IF(MERR.EQ.3) CALL PYERRM(17,
     &      '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
            IF(MERR.EQ.2) CALL PYERRM(17,
     &      '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
            IF(MERR.EQ.1) CALL PYERRM(7,
     &      '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
            BRSUM=BRSUM+BRAT(IDC)
  210     CONTINUE
          WRITE(CHTMP,5500) BRSUM
          IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
     &    CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
     &    CHTMP(9:16)//' for KF ='//CHKF)
  220   CONTINUE
 
C...Write DATA statements for inclusion in program.
      ELSEIF(MUPDA.EQ.4) THEN
 
C...Find out how many codes and decay channels are actually used.
        KCC=0
        NDC=0
        DO 230 I=1,MSTU(6)
          IF(KCHG(I,4).NE.0) THEN
            KCC=I
            NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
          ENDIF
  230   CONTINUE
 
C...Initialize writing of DATA statements for inclusion in program.
        DO 300 IVAR=1,22
          NDIM=MSTU(6)
          IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
          NLIN=1
          CHLIN=' '
          CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I=   1,    )/'
          LLIN=35
          CHOLD='START'
 
C...Loop through variables for conversion to characters.
          DO 280 IDIM=1,NDIM
            IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
            IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
            IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
            IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
            IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
            IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
            IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
            IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
            IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
            IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
            IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
            IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
            IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
            IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
            IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
            IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
            IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
            IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
            IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
            IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
            IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
            IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
 
C...Replace variables beyond what is properly defined.
            IF(IVAR.LE.4) THEN
              IF(IDIM.GT.KCC) CHTMP='               0'
            ELSEIF(IVAR.LE.8) THEN
              IF(IDIM.GT.KCC) CHTMP='             0.0'
            ELSEIF(IVAR.LE.11) THEN
              IF(IDIM.GT.KCC) CHTMP='               0'
            ELSEIF(IVAR.LE.13) THEN
              IF(IDIM.GT.NDC) CHTMP='               0'
            ELSEIF(IVAR.LE.14) THEN
              IF(IDIM.GT.NDC) CHTMP='             0.0'
            ELSEIF(IVAR.LE.19) THEN
              IF(IDIM.GT.NDC) CHTMP='               0'
            ELSEIF(IVAR.LE.21) THEN
              IF(IDIM.GT.KCC) CHTMP='                '
            ELSE
              IF(IDIM.GT.KCC) CHTMP='               0'
            ENDIF
 
C...Length of variable, trailing decimal zeros, quotation marks.
            LLOW=1
            LHIG=1
            DO 240 LL=1,16
              IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
              IF(CHTMP(LL:LL).NE.' ') LHIG=LL
  240       CONTINUE
            CHNEW=CHTMP(LLOW:LHIG)//' '
            LNEW=1+LHIG-LLOW
            IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
              LNEW=LNEW+1
  250         LNEW=LNEW-1
              IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
              IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
              IF(LNEW.EQ.0) THEN
                CHNEW(1:3)='0D0'
                LNEW=3
              ELSE
                CHNEW(LNEW+1:LNEW+2)='D0'
                LNEW=LNEW+2
              ENDIF
            ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
              DO 260 LL=LNEW,1,-1
                IF(CHNEW(LL:LL).EQ.'''') THEN
                  CHTMP=CHNEW
                  CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
                  LNEW=LNEW+1
                ENDIF
  260         CONTINUE
              LNEW=MIN(14,LNEW)
              CHTMP=CHNEW
              CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
              LNEW=LNEW+2
            ENDIF
 
C...Form composite character string, often including repetition counter.
            IF(CHNEW.NE.CHOLD) THEN
              NRPT=1
              CHOLD=CHNEW
              CHCOM=CHNEW
              LCOM=LNEW
            ELSE
              LRPT=LNEW+1
              IF(NRPT.GE.2) LRPT=LNEW+3
              IF(NRPT.GE.10) LRPT=LNEW+4
              IF(NRPT.GE.100) LRPT=LNEW+5
              IF(NRPT.GE.1000) LRPT=LNEW+6
              LLIN=LLIN-LRPT
              NRPT=NRPT+1
              WRITE(CHTMP,5400) NRPT
              LRPT=1
              IF(NRPT.GE.10) LRPT=2
              IF(NRPT.GE.100) LRPT=3
              IF(NRPT.GE.1000) LRPT=4
              CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
              LCOM=LRPT+1+LNEW
            ENDIF
 
C...Add characters to end of line, to new line (after storing old line),
C...or to new block of lines (after writing old block).
            IF(LLIN+LCOM.LE.70) THEN
              CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
              LLIN=LLIN+LCOM+1
            ELSEIF(NLIN.LE.19) THEN
              CHLIN(LLIN+1:72)=' '
              CHBLK(NLIN)=CHLIN
              NLIN=NLIN+1
              CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
              LLIN=6+LCOM+1
            ELSE
              CHLIN(LLIN:72)='/'//' '
              CHBLK(NLIN)=CHLIN
              WRITE(CHTMP,5400) IDIM-NRPT
              CHBLK(1)(30:33)=CHTMP(13:16)
              DO 270 ILIN=1,NLIN
                WRITE(LFN,5700) CHBLK(ILIN)
  270         CONTINUE
              NLIN=1
              CHLIN=' '
              CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
     &        ',I=    ,    )/'//CHCOM(1:LCOM)//','
              WRITE(CHTMP,5400) IDIM-NRPT+1
              CHLIN(25:28)=CHTMP(13:16)
              LLIN=35+LCOM+1
            ENDIF
  280     CONTINUE
 
C...Write final block of lines.
          CHLIN(LLIN:72)='/'//' '
          CHBLK(NLIN)=CHLIN
          WRITE(CHTMP,5400) NDIM
          CHBLK(1)(30:33)=CHTMP(13:16)
          DO 290 ILIN=1,NLIN
            WRITE(LFN,5700) CHBLK(ILIN)
  290     CONTINUE
  300   CONTINUE
      ENDIF
 
C...Formats for reading and writing particle data.
 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
 5100 FORMAT(10X,2I5,F12.6,5I10)
 5200 FORMAT(A120)
 5300 FORMAT(I9)
 5400 FORMAT(I16)
 5500 FORMAT(F16.5)
 5600 FORMAT(F16.6)
 5700 FORMAT(A72)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYK
C...Provides various integer-valued event related data.
 
      FUNCTION PYK(I,J)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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) THEN
          IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
        ENDIF
        IF(J.EQ.15) PYK=I2
      ELSEIF(J.EQ.16) THEN
        KFA=IABS(K(I,2))
        IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
     &  (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
          I1=I
  120     I2=I1
          I1=K(I1,3)
          IF(I1.GT.0) THEN
            KFAM=IABS(K(I1,2))
            ILP=1
            IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
            IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
     &      ILP=0
            IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
            IF(ILP.EQ.1) GOTO 120
          ENDIF
          IF(K(I1,1).EQ.12) THEN
            DO 130 I3=I1+1,I2
              IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
     &        .AND.K(I3,2).NE.93) PYK=PYK+1
  130       CONTINUE
          ELSE
            I3=I2
  140       PYK=PYK+1
            I3=I3+1
            IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
          ENDIF
        ENDIF
 
C...Particle coming from collapsing jet system or not.
      ELSEIF(J.EQ.17) THEN
        I1=I
  150   PYK=PYK+1
        I3=I1
        I1=K(I1,3)
        I0=MAX(1,I1)
        KC=PYCOMP(K(I0,2))
        IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
          IF(PYK.EQ.1) PYK=-1
          IF(PYK.GT.1) PYK=0
          RETURN
        ENDIF
        IF(KCHG(KC,2).EQ.0) GOTO 150
        IF(K(I1,1).NE.12) PYK=0
        IF(K(I1,1).NE.12) RETURN
        I2=I1
  160   I2=I2+1
        IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
        K3M=K(I3-1,3)
        IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
        K3P=K(I3+1,3)
        IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
 
C...Number of decay products. Colour flow.
      ELSEIF(J.EQ.18) THEN
        IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
        IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
      ELSEIF(J.LE.22) THEN
        IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
        IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
        IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
        IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
        IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
      ELSE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYP
C...Provides various real-valued event related data.
 
      FUNCTION PYP(I,J)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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
        RETURN
      ENDIF
      IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
      IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
      NSAV=NJET
 
      RETURN
      END
 
C*********************************************************************
 
C...PYCELL
C...Provides a simple way of jet finding in eta-phi-ET coordinates,
C...as used for calorimeters at hadron colliders.
 
      SUBROUTINE PYCELL(NJET)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...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)=MAX(0,NJET)
      IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYJMAS
C...Determines, approximately, the two jet masses that minimize
C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
 
      SUBROUTINE PYJMAS(PMH,PML)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Status, (optimized) Q^2 scale, alpha_strong.
      PARJ(151)=ECM
      MSTJ(119)=10*MSTJ(102)+KFL
      IF(MSTJ(111).EQ.0) THEN
        Q2R=ECM**2
      ELSEIF(MSTU(111).EQ.0) THEN
        PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
     &  ((33D0-2D0*MSTU(112))*PARU(111)))))
        Q2R=PARJ(168)*ECM**2
      ELSE
        PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
     &  (2D0*PARU(112)/ECM)**2))
        Q2R=PARJ(168)*ECM**2
      ENDIF
      ALSPI=PYALPS(Q2R)/PARU(1)
 
C...QCD corrections factor in R.
      IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
        RQCD=1D0
      ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
        RQCD=1D0+ALSPI
      ELSEIF(MSTJ(109).EQ.0) THEN
        RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
        IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
     &  LOG(PARJ(168))*ALSPI**2)
      ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
        RQCD=1D0+(3D0/4D0)*ALSPI
      ELSE
        RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
      ENDIF
 
C...Calculate Z0 width if default value not acceptable.
      IF(MSTJ(102).GE.3) THEN
        RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
     &  (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
        DO 100 KFLC=5,6
          VQ=1D0
          IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
     &    (2D0*PYMASS(KFLC)/ ECM)**2))
          IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
          IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
          RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
  100   CONTINUE
        PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
     &  (1D0-PARU(102)))
      ENDIF
 
C...Calculate propagator and related constants for QFD case.
      POLL=1D0-PARJ(131)*PARJ(132)
      IF(MSTJ(102).GE.2) THEN
        SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
        SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
        SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
        VE=4D0*PARU(102)-1D0
        SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
        SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
        HF1I=SFI*SF1I
        HF1W=SFW*SF1W
      ENDIF
 
C...Loop over different flavours: charge, velocity.
      RTOT=0D0
      RQQ=0D0
      RQV=0D0
      RVA=0D0
      DO 110 KFLC=1,MAX(MSTJ(104),KFL)
        IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
        MSTJ(93)=1
        PMQ=PYMASS(KFLC)
        IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
        QF=KCHG(KFLC,1)/3D0
        VQ=1D0
        IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
 
C...Calculate R and sum of charges for QED or QFD case.
        RQQ=RQQ+3D0*QF**2*POLL
        IF(MSTJ(102).LE.1) THEN
          RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
        ELSE
          VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
          RQV=RQV-6D0*QF*VF*SF1I
          RVA=RVA+3D0*(VF**2+1D0)*SF1W
          RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
     &    2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
        ENDIF
  110 CONTINUE
      RSUM=RQQ
      IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
 
C...Calculate cross-section, including QCD corrections.
      PARJ(141)=RQQ
      PARJ(142)=RTOT
      PARJ(143)=RTOT*RQCD
      PARJ(144)=PARJ(143)
      PARJ(145)=PARJ(141)*86.8D0/ECM**2
      PARJ(146)=PARJ(142)*86.8D0/ECM**2
      PARJ(147)=PARJ(143)*86.8D0/ECM**2
      PARJ(148)=PARJ(147)
      PARJ(157)=RSUM*RQCD
      PARJ(158)=0D0
      PARJ(159)=0D0
      XTOT=PARJ(147)
      IF(MSTJ(107).LE.0) RETURN
 
C...Virtual cross-section.
      XKL=PARJ(135)
      XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
      ALE=2D0*LOG(ECM/PYMASS(11))-1D0
      SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
     &1.526D0*LOG(ECM**2/0.932D0)
 
C...Soft and hard radiative cross-section in QED case.
      IF(MSTJ(102).LE.1) THEN
        SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
        SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
        SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
 
C...Soft and hard radiative cross-section in QFD case.
      ELSE
        SZM=1D0-(PARJ(123)/ECM)**2
        SZW=PARJ(123)*PARJ(124)/ECM**2
        PARJ(161)=-RQQ/RSUM
        PARJ(162)=-(RQQ+RQV+RVA)/RSUM
        PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
        PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
     &  4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
        SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
     &  RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
        SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
     &  PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
     &  PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
        SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
     &  (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
     &  LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
     &  PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
      ENDIF
 
C...Total cross-section and fraction of hard photon events.
      PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
      PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
      PARJ(144)=PARJ(157)
      PARJ(148)=PARJ(144)*86.8D0/ECM**2
      XTOT=PARJ(148)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRADK
C...Generates initial state photon radiation.
 
      SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Function: cumulative hard photon spectrum in QFD case.
      FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
     &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
 
C...Determine whether radiative photon or not.
      MK=0
      PAK=0D0
      IF(PARJ(160).LT.PYR(0)) RETURN
      MK=1
 
C...Photon energy range. Find photon momentum in QED case.
      XKL=PARJ(135)
      XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
      IF(MSTJ(102).LE.1) THEN
  100   XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
        IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
 
C...Ditto in QFD case, by numerical inversion of integrated spectrum.
      ELSE
        SZM=1D0-(PARJ(123)/ECM)**2
        SZW=PARJ(123)*PARJ(124)/ECM**2
        FXKL=FXK(XKL)
        FXKU=FXK(XKU)
        FXKD=1D-4*(FXKU-FXKL)
        FXKR=FXKL+PYR(0)*(FXKU-FXKL)
        NXK=0
  110   NXK=NXK+1
        XK=0.5D0*(XKL+XKU)
        FXKV=FXK(XK)
        IF(FXKV.GT.FXKR) THEN
          XKU=XK
          FXKU=FXKV
        ELSE
          XKL=XK
          FXKL=FXKV
        ENDIF
        IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
        XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
      ENDIF
      PAK=0.5D0*ECM*XK
 
C...Photon polar and azimuthal angle.
      PME=2D0*(PYMASS(11)/ECM)**2
  120 CTHM=PME*(2D0/PME)**PYR(0)
      IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
     &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
      CTHE=1D0-CTHM
      IF(PYR(0).GT.0.5D0) CTHE=-CTHE
      STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
      THEK=PYANGL(CTHE,STHE)
      PHIK=PARU(2)*PYR(0)
 
C...Rotation angle for hadronic system.
      SGN=1D0
      IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
     &PYR(0)) SGN=-1D0
      ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
     &(2D0-XK*(1D0-SGN*CTHE)))
 
      RETURN
      END
 
C*********************************************************************
 
C...PYXKFL
C...Selects flavour for produced qqbar pair.
 
      SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      SAVE /PYDAT1/,/PYDAT2/
 
C...Calculate maximum weight in QED or QFD case.
      IF(MSTJ(102).LE.1) THEN
        RFMAX=4D0/9D0
      ELSE
        POLL=1D0-PARJ(131)*PARJ(132)
        SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
        SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
        SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
        VE=4D0*PARU(102)-1D0
        HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
        HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
        RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
     &  ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
     &  (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
     &  1D0)*HF1W)
      ENDIF
 
C...Choose flavour. Gives charge and velocity.
      NTRY=0
  100 NTRY=NTRY+1
      IF(NTRY.GT.100) THEN
        CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
        KFLC=0
        RETURN
      ENDIF
      KFLC=KFL
      IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
      MSTJ(93)=1
      PMQ=PYMASS(KFLC)
      IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
      QF=KCHG(KFLC,1)/3D0
      VQ=1D0
      IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
 
C...Calculate weight in QED or QFD case.
      IF(MSTJ(102).LE.1) THEN
        RF=QF**2
        RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
      ELSE
        VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
        RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
        RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
     &  VQ**3*HF1W
        IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
      ENDIF
 
C...Weighting or new event (radiative photon). Cross-section update.
      IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
      PARJ(158)=PARJ(158)+1D0
      IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
      IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
      IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
      PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
      PARJ(148)=PARJ(144)*86.8D0/ECM**2
 
      RETURN
      END
 
C*********************************************************************
 
C...PYXJET
C...Selects number of jets in matrix element approach.
 
      SUBROUTINE PYXJET(ECM,NJET,CUT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local array and data.
      DIMENSION ZHUT(5)
      DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
 
C...Trivial result for two-jets only, including parton shower.
      IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
        CUT=0D0
 
C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
      ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
        CF=4D0/3D0
        IF(MSTJ(109).EQ.2) CF=1D0
        IF(MSTJ(111).EQ.0) THEN
          Q2=ECM**2
          Q2R=ECM**2
        ELSEIF(MSTU(111).EQ.0) THEN
          PARJ(169)=MIN(1D0,PARJ(129))
          Q2=PARJ(169)*ECM**2
          PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
     &    ((33D0-2D0*MSTU(112))*PARU(111)))))
          Q2R=PARJ(168)*ECM**2
        ELSE
          PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
          Q2=PARJ(169)*ECM**2
          PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
     &    (2D0*PARU(112)/ECM)**2))
          Q2R=PARJ(168)*ECM**2
        ENDIF
 
C...alpha_strong for R and R itself.
        ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
        IF(IABS(MSTJ(101)).EQ.1) THEN
          RQCD=1D0+ALSPI
        ELSEIF(MSTJ(109).EQ.0) THEN
          RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
          IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
     &    (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
        ELSE
          RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
        ENDIF
 
C...alpha_strong for jet rate. Initial value for y cut.
        ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
        CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
        IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
     &  CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
        IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
 
C...Parametrization of first order three-jet cross-section.
  100   IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
          PARJ(152)=0D0
        ELSE
          PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
     &    LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
     &    (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
     &    (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
          IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
     &    PARJ(152)=0D0
        ENDIF
 
C...Parametrization of second order three-jet cross-section.
        IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
     &  CUT.GE.0.25D0) THEN
          PARJ(153)=0D0
        ELSEIF(MSTJ(110).LE.1) THEN
          CT=LOG(1D0/CUT-2D0)
          PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
     &    0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
 
C...Interpolation in second/first order ratio for Zhu parametrization.
        ELSEIF(MSTJ(110).EQ.2) THEN
          IZA=0
          DO 110 IY=1,5
            IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
  110     CONTINUE
          IF(IZA.NE.0) THEN
            ZHURAT=ZHUT(IZA)
          ELSE
            IZ=100D0*CUT
            ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
          ENDIF
          PARJ(153)=ALSPI*PARJ(152)*ZHURAT
        ENDIF
 
C...Shift in second order three-jet cross-section with optimized Q^2.
        IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
     &  .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
     &  (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
 
C...Parametrization of second order four-jet cross-section.
        IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
          PARJ(154)=0D0
        ELSE
          CT=LOG(1D0/CUT-5D0)
          IF(CUT.LE.0.018D0) THEN
            XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
            IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
     &      0.4059D0*CT**2)
            XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
            IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
          ELSE
            XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
            IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
     &      0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
            XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
     &      0.002093D0*CT**3)
            IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
          ENDIF
          PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
          PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
        ENDIF
 
C...If negative three-jet rate, change y' optimization parameter.
        IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
     &  PARJ(169).LT.0.99D0) THEN
          PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
          Q2=PARJ(169)*ECM**2
          ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
          GOTO 100
        ENDIF
 
C...If too high cross-section, use harder cuts, or fail.
        IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
          IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
     &    PARJ(169).LT.0.99D0) THEN
            PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
            Q2=PARJ(169)*ECM**2
            ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
            GOTO 100
          ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
            CALL PYERRM(26,
     &      '(PYXJET:) no allowed y cut value for Zhu parametrization')
          ENDIF
          CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
     &    PARJ(154))**(-1D0/3D0)
          IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
          GOTO 100
        ENDIF
 
C...Scalar gluon (first order only).
      ELSE
        ALSPI=PYALPS(ECM**2)/PARU(1)
        CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
        PARJ(152)=0D0
        IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
     &  LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
        PARJ(153)=0D0
        PARJ(154)=0D0
      ENDIF
 
C...Select number of jets.
      PARJ(150)=CUT
      IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
        NJET=2
      ELSEIF(MSTJ(101).LE.0) THEN
        NJET=MIN(4,2-MSTJ(101))
      ELSE
        RNJ=PYR(0)
        NJET=2
        IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
        IF(PARJ(154).GT.RNJ) NJET=4
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYX3JT
C...Selects the kinematical variables of three-jet events.
 
      SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local array.
      DIMENSION ZHUP(5,12)
 
C...Coefficients of Zhu second order parametrization.
      DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
     &18.29D0,  89.56D0,  4.541D0,  -52.09D0, -109.8D0,  24.90D0,
     &11.63D0,  3.683D0,  17.50D0,0.002440D0, -1.362D0,-0.3537D0,
     &11.42D0,  6.299D0, -22.55D0,  -8.915D0,  59.25D0, -5.855D0,
     &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
     &7.847D0, -3.964D0, -35.83D0,   1.178D0,  29.39D0, 0.2806D0,
     &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
     &5.441D0, -56.89D0, -50.27D0,   15.13D0,  114.3D0, -18.19D0,
     &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
     &-17.65D0,  51.44D0, -58.32D0,   70.95D0, -255.7D0, -78.99D0,
     &476.9D0,  29.65D0, -239.3D0,  0.4745D0, -1.174D0,  6.081D0/
 
C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
      DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
     &X**7/49D0
 
C...Event type. Mass effect factors and other common constants.
      MSTJ(120)=2
      MSTJ(121)=0
      PMQ=PYMASS(KFL)
      QME=(2D0*PMQ/ECM)**2
      IF(MSTJ(109).NE.1) THEN
        CUTL=LOG(CUT)
        CUTD=LOG(1D0/CUT-2D0)
        IF(MSTJ(109).EQ.0) THEN
          CF=4D0/3D0
          CN=3D0
          TR=2D0
          WTMX=MIN(20D0,37D0-6D0*CUTD)
          IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
        ELSE
          CF=1D0
          CN=0D0
          TR=12D0
          WTMX=0D0
        ENDIF
 
C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
        ALS2PI=PARU(118)/PARU(2)
        WTOPT=0D0
        IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
     &  LOG(PARJ(169))*ALS2PI
        WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
 
C...Choose three-jet events in allowed region.
  100   NJET=3
  110   Y13L=CUTL+CUTD*PYR(0)
        Y23L=CUTL+CUTD*PYR(0)
        Y13=EXP(Y13L)
        Y23=EXP(Y23L)
        Y12=1D0-Y13-Y23
        IF(Y12.LE.CUT) GOTO 110
        IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
 
C...Second order corrections.
        IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
          Y12L=LOG(Y12)
          Y13M=LOG(1D0-Y13)
          Y23M=LOG(1D0-Y23)
          Y12M=LOG(1D0-Y12)
          IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
          IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
          IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
          IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
          IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
          IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
          WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
          WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
     &    2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
     &    CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
     &    11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
     &    (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
     &    TR*(2D0*CUTL/3D0-10D0/9D0)+
     &    CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
     &    Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
     &    (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
     &    Y13*Y23)/(Y12+Y13)**2)/WT1+
     &    CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
     &    ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
     &    Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
     &    (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
     &    (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
     &    2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
     &    CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
          IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
          IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
          PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
 
        ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
C...Second order corrections; Zhu parametrization of ERT.
          ZX=(Y23-Y13)**2
          ZY=1D0-Y12
          IZA=0
          DO 120 IY=1,5
            IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
  120     CONTINUE
          IF(IZA.NE.0) THEN
            IZ=IZA
            WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
     &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
     &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
     &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
          ELSE
            IZ=100D0*CUT
            WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
     &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
     &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
     &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
            IZ=IZ+1
            WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
     &      ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
     &      (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
     &      ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
            WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
          ENDIF
          IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
          IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
          PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
        ENDIF
 
C...Impose mass cuts (gives two jets). For fixed jet number new try.
        X1=1D0-Y23
        X2=1D0-Y13
        X3=1D0-Y12
        IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
        IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
     &  0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
     &  (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
        IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
 
C...Scalar gluon model (first order only, no mass effects).
      ELSE
  130   NJET=3
  140   X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
        IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
        YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
        X1=1D0-0.5D0*(X3+YD)
        X2=1D0-0.5D0*(X3-YD)
        IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
        IF(MSTJ(102).GE.2) THEN
          IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
     &    X3**2*PYR(0)) NJET=2
        ENDIF
        IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYX4JT
C...Selects the kinematical variables of four-jet events.
 
      SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local arrays.
      DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
 
C...Common constants. Colour factors for QCD and Abelian gluon theory.
      PMQ=PYMASS(KFL)
      QME=(2D0*PMQ/ECM)**2
      CT=LOG(1D0/CUT-5D0)
      IF(MSTJ(109).EQ.0) THEN
        CF=4D0/3D0
        CN=3D0
        TR=2.5D0
      ELSE
        CF=1D0
        CN=0D0
        TR=15D0
      ENDIF
 
C...Choice of process (qqbargg or qqbarqqbar).
  100 NJET=4
      IT=1
      IF(PARJ(155).GT.PYR(0)) IT=2
      IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
      IF(IT.EQ.1) WTMX=0.7D0/CUT**2
      IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
      IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
      ID=1
 
C...Sample the five kinematical variables (for qqgg preweighted in y34).
  110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
      Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
      IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
      IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
      IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
      VT=PYR(0)
      CP=COS(PARU(1)*PYR(0))
      Y14=(Y134-Y34)*VT
      Y13=Y134-Y14-Y34
      VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
      Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
     &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
      Y23=Y234-Y34-Y24
      Y12=1D0-Y134-Y23-Y24
      IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
      Y123=Y12+Y13+Y23
      Y124=Y12+Y14+Y24
 
C...Calculate matrix elements for qqgg or qqqq process.
      IC=0
      WTTOT=0D0
  120 IC=IC+1
      IF(IT.EQ.1) THEN
        WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
     &  3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
     &  Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
     &  Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
     &  2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
     &  (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
     &  Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
     &  (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
        WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
     &  Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
     &  Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
     &  Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
        WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
     &  2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
     &  Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
     &  3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
     &  3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
     &  (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
     &  3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
     &  2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
     &  2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
     &  3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
     &  2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
     &  2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
        WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
     &  4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
     &  Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
     &  4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
     &  2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
     &  4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
     &  (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
     &  2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
     &  2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
     &  4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
     &  Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
     &  4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
     &  4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
     &  2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
     &  2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
     &  Y12*Y13**2)/(4D0*Y34**2*Y134**2)
        WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
     &  CN*WTC(IC))/8D0
      ELSE
        WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
     &  Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
     &  Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
     &  Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
     &  Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
     &  Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
     &  Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
     &  Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
     &  Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
        WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
     &  Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
     &  Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
     &  Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
     &  (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
     &  Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
     &  Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
     &  Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
        WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
      ENDIF
 
C...Permutations of momenta in matrix element. Weighting.
  130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
        YSAV=Y13
        Y13=Y14
        Y14=YSAV
        YSAV=Y23
        Y23=Y24
        Y24=YSAV
        YSAV=Y123
        Y123=Y124
        Y124=YSAV
      ENDIF
      IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
        YSAV=Y13
        Y13=Y23
        Y23=YSAV
        YSAV=Y14
        Y14=Y24
        Y24=YSAV
        YSAV=Y134
        Y134=Y234
        Y234=YSAV
      ENDIF
      IF(IC.LE.3) GOTO 120
      IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
      IC=5
 
C...qqgg events: string configuration and event type.
      IF(IT.EQ.1) THEN
        IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
          PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
     &    WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
          IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
     &    WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
          IF(ID.EQ.2) GOTO 130
        ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
          PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
          IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
          IF(ID.EQ.2) GOTO 130
        ENDIF
        MSTJ(120)=3
        IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
     &  WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
        KFLN=21
 
C...Mass cuts. Kinematical variables out.
        IF(Y12.LE.CUT+QME) NJET=2
        IF(NJET.EQ.2) GOTO 150
        Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
        X1=1D0-(1D0-Q12)*Y234-Q12*Y134
        X4=1D0-(1D0-Q12)*Y134-Q12*Y234
        X2=1D0-Y124
        X12=(1D0-Q12)*Y13+Q12*Y23
        X14=Y12-0.5D0*QME
        IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
 
C...qqbarqqbar events: string configuration, choose new flavour.
      ELSE
        IF(ID.EQ.1) THEN
          WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
          IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
          IF(WTR.LT.WTD(3)+WTD(4)) ID=3
          IF(WTR.LT.WTD(4)) ID=4
          IF(ID.GE.2) GOTO 130
        ENDIF
        MSTJ(120)=5
        PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
  140   KFLN=1+INT(5D0*PYR(0))
        IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
        IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
        IF(KFLN.GT.MSTJ(104)) NJET=2
        PMQN=PYMASS(KFLN)
        QMEN=(2D0*PMQN/ECM)**2
 
C...Mass cuts. Kinematical variables out.
        IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
        IF(NJET.EQ.2) GOTO 150
        Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
        Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
        X1=1D0-(1D0-Q24)*Y123-Q24*Y134
        X4=1D0-(1D0-Q24)*Y134-Q24*Y123
        X2=1D0-(1D0-Q13)*Y234-Q13*Y124
        X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
     &  Q13*Y23)
        X14=Y24-0.5D0*QME
        X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
     &  Q13*Y14)
        IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
     &  (PARJ(127)+PMQ+PMQN)**2) NJET=2
        IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
      ENDIF
  150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
 
      RETURN
      END
 
C*********************************************************************
 
C...PYXDIF
C...Gives the angular orientation of events.
 
      SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
C...Local character variables.
      CHARACTER TITLE*(*), TITFX*60
 
C...Check that input is sensible. Find initial address in memory.
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
     &'(PYBOOK:) not allowed histogram number')
      IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
     &'(PYBOOK:) not allowed number of bins')
      IF(XL.GE.XU) CALL PYERRM(28,
     &'(PYBOOK:) x limits in wrong order')
      INDX(ID)=IHIST(4)
      IHIST(4)=IHIST(4)+28+NX
      IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
     &'(PYBOOK:) out of histogram space')
      IS=INDX(ID)
 
C...Store histogram size and reset contents.
      BIN(IS+1)=NX
      BIN(IS+2)=XL
      BIN(IS+3)=XU
      BIN(IS+4)=(XU-XL)/NX
      CALL PYNULL(ID)
 
C...Store title by conversion to integer to double precision.
      TITFX=TITLE//' '
      DO 100 IT=1,20
        BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
     &  256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYFILL
C...Fills entry in histogram.
 
      SUBROUTINE PYFILL(ID,X,W)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
 
C...Find initial address in memory. Increase number of entries.
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
     &'(PYFILL:) not allowed histogram number')
      IS=INDX(ID)
      IF(IS.EQ.0) CALL PYERRM(28,
     &'(PYFILL:) filling unbooked histogram')
      BIN(IS+5)=BIN(IS+5)+1D0
 
C...Find bin in x, including under/overflow, and fill.
      IF(X.LT.BIN(IS+2)) THEN
        BIN(IS+6)=BIN(IS+6)+W
      ELSEIF(X.GE.BIN(IS+3)) THEN
        BIN(IS+8)=BIN(IS+8)+W
      ELSE
        BIN(IS+7)=BIN(IS+7)+W
        IX=(X-BIN(IS+2))/BIN(IS+4)
        IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
        BIN(IS+9+IX)=BIN(IS+9+IX)+W
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYFACT
C...Multiplies histogram contents by factor.
 
      SUBROUTINE PYFACT(ID,F)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
 
C...Find initial address in memory. Multiply all contents bins.
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
     &'(PYFACT:) not allowed histogram number')
      IS=INDX(ID)
      IF(IS.EQ.0) CALL PYERRM(28,
     &'(PYFACT:) scaling unbooked histogram')
      DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
        BIN(IX)=F*BIN(IX)
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYOPER
C...Performs operations between histograms.
 
      SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
C...Character variable.
      CHARACTER OPER*(*)
 
C...Find initial addresses in memory, and histogram size.
      IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
     &'(PYFACT:) not allowed histogram number')
      IS1=INDX(ID1)
      IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
      IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
      NX=NINT(BIN(IS3+1))
      IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
 
C...Update info on number of histogram entries.
      IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
        BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
      ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
        BIN(IS3+5)=BIN(IS1+5)
      ENDIF
 
C...Operations on pair of histograms: addition, subtraction,
C...multiplication, division.
      IF(OPER.EQ.'+') THEN
        DO 100 IX=6,8+NX
          BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
  100   CONTINUE
      ELSEIF(OPER.EQ.'-') THEN
        DO 110 IX=6,8+NX
          BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
  110   CONTINUE
      ELSEIF(OPER.EQ.'*') THEN
        DO 120 IX=6,8+NX
          BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
  120   CONTINUE
      ELSEIF(OPER.EQ.'/') THEN
        DO 130 IX=6,8+NX
          FA2=F2*BIN(IS2+IX)
          IF(ABS(FA2).LE.1D-20) THEN
            BIN(IS3+IX)=0D0
          ELSE
            BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
          ENDIF
  130   CONTINUE
 
C...Operations on single histogram: multiplication+addition,
C...square root+addition, logarithm+addition.
      ELSEIF(OPER.EQ.'A') THEN
        DO 140 IX=6,8+NX
          BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
  140   CONTINUE
      ELSEIF(OPER.EQ.'S') THEN
        DO 150 IX=6,8+NX
          BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
  150   CONTINUE
      ELSEIF(OPER.EQ.'L') THEN
        ZMIN=1D20
        DO 160 IX=9,8+NX
          IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
     &    ZMIN=0.8D0*BIN(IS1+IX)
  160   CONTINUE
        DO 170 IX=6,8+NX
          BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
  170   CONTINUE
 
C...Operation on two or three histograms: average and
C...standard deviation.
      ELSEIF(OPER.EQ.'M') THEN
        DO 180 IX=6,8+NX
          IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
            BIN(IS2+IX)=0D0
          ELSE
            BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
          ENDIF
          IF(ID3.NE.0) THEN
            IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
              BIN(IS3+IX)=0D0
            ELSE
              BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
     &        BIN(IS2+IX)**2))
            ENDIF
          ENDIF
          BIN(IS1+IX)=F1*BIN(IS1+IX)
  180   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYHIST
C...Prints and resets all histograms.
 
      SUBROUTINE PYHIST
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
 
C...Loop over histograms, print and reset used ones.
      DO 100 ID=1,IHIST(1)
        IS=INDX(ID)
        IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
          CALL PYPLOT(ID)
          CALL PYNULL(ID)
        ENDIF
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPLOT
C...Prints a histogram (but does not reset it).
 
      SUBROUTINE PYPLOT(ID)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYDAT1/,/PYBINS/
C...Local arrays and character variables.
      DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
      CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
 
C...Steps in histogram scale. Character sequence.
      DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
      DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
 
C...Find initial address in memory; skip if empty histogram.
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
      IS=INDX(ID)
      IF(IS.EQ.0) RETURN
      IF(NINT(BIN(IS+5)).LE.0) THEN
        WRITE(MSTU(11),5000) ID
        RETURN
      ENDIF
 
C...Number of histogram lines and x bins.
      LIN=IHIST(3)-18
      NX=NINT(BIN(IS+1))
 
C...Extract title by conversion from double precision via integer.
      DO 100 IT=1,20
        IEQ=NINT(BIN(IS+8+NX+IT))
        TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
     &  //CHAR(MOD(IEQ,256))
  100 CONTINUE
 
C...Find time; print title.
      CALL PYTIME(IDATI)
      IF(IDATI(1).GT.0) THEN
        WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
      ELSE
        WRITE(MSTU(11),5200) ID, TITLE
      ENDIF
 
C...Find minimum and maximum bin content.
      YMIN=BIN(IS+9)
      YMAX=BIN(IS+9)
      DO 110 IX=IS+10,IS+8+NX
        IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
        IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
  110 CONTINUE
 
C...Determine scale and step size for y axis.
      IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
        IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
        IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
        IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
        IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
        IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
        DELY=DYAC(1)
        DO 120 IDEL=1,9
          IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
  120   CONTINUE
        DY=DELY*10D0**IPOT
 
C...Convert bin contents to integer form; fractional fill in top row.
        DO 130 IX=1,NX
          CTA=ABS(BIN(IS+8+IX))/DY
          IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
          IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
  130   CONTINUE
        IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
        IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
 
C...Print histogram row by row.
        DO 150 IR=IRMA,IRMI,-1
          IF(IR.EQ.0) GOTO 150
          OUT=' '
          DO 140 IX=1,NX
            IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
            IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
  140     CONTINUE
          WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
  150   CONTINUE
 
C...Print sign and value of bin contents.
        IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
        OUT=' '
        DO 160 IX=1,NX
          IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
          IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
  160   CONTINUE
        WRITE(MSTU(11),5400) OUT
        DO 180 IR=4,1,-1
          DO 170 IX=1,NX
            OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
  170     CONTINUE
          WRITE(MSTU(11),5500) IPOT+IR-4, OUT
  180   CONTINUE
 
C...Print sign and value of lower bin edge.
        IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
     &  10.0001D0)-10
        OUT=' '
        DO 190 IX=1,NX
          IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
     &    OUT(IX:IX)=CHA(11)
          IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
  190   CONTINUE
        WRITE(MSTU(11),5600) OUT
        DO 210 IR=3,1,-1
          DO 200 IX=1,NX
            OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
  200     CONTINUE
          WRITE(MSTU(11),5500) IPOT+IR-3, OUT
  210   CONTINUE
      ENDIF
 
C...Calculate and print statistics.
      CSUM=0D0
      CXSUM=0D0
      CXXSUM=0D0
      DO 220 IX=1,NX
        CTA=ABS(BIN(IS+8+IX))
        X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
        CSUM=CSUM+CTA
        CXSUM=CXSUM+CTA*X
        CXXSUM=CXXSUM+CTA*X**2
  220 CONTINUE
      XMEAN=CXSUM/MAX(CSUM,1D-20)
      XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
      WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
     &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
 
C...Formats for output.
 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
     &I2,':',I2/)
 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
 5400 FORMAT(/8X,'Contents',3X,A100)
 5500 FORMAT(9X,'*10**',I2,3X,A100)
 5600 FORMAT(/8X,'Low edge',3X,A100)
 5700 FORMAT(/5X,'Entries  =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
     &,D12.4,6X,'Low edge  =',D12.4/5X,'All chan =',D12.4,6X,
     &'Rms  =',D12.4,6X,'Overflow  =',D12.4,6X,'High edge =',D12.4)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYNULL
C...Resets bin contents of a histogram.
 
      SUBROUTINE PYNULL(ID)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
 
      IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
      IS=INDX(ID)
      IF(IS.EQ.0) RETURN
      DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
        BIN(IX)=0D0
  100 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYDUMP
C...Dumps histogram contents on file for reading by other program.
C...Can also read back own dump.
 
      SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
 
C...Double precision declaration.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Commonblock.
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      SAVE /PYBINS/
C...Local arrays and character variables.
      DIMENSION IHI(*),ISS(100),VAL(5)
      CHARACTER TITLE*60,FORMAT*13
 
C...Dump all histograms that have been booked,
C...including titles and ranges, one after the other.
      IF(MDUMP.EQ.1) THEN
 
C...Loop over histograms and find which are wanted and booked.
        IF(NHI.LE.0) THEN
          NW=IHIST(1)
        ELSE
          NW=NHI
        ENDIF
        DO 130 IW=1,NW
          IF(NHI.EQ.0) THEN
            ID=IW
          ELSE
            ID=IHI(IW)
          ENDIF
          IS=INDX(ID)
          IF(IS.NE.0) THEN
 
C...Write title, histogram size, filling statistics.
            NX=NINT(BIN(IS+1))
            DO 100 IT=1,20
              IEQ=NINT(BIN(IS+8+NX+IT))
              TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
     &        CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
  100       CONTINUE
            WRITE(LFN,5100) ID,TITLE
            WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
            WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
     &      BIN(IS+8)
 
 
C...Write histogram contents, in groups of five.
            DO 120 IXG=1,(NX+4)/5
              DO 110 IXV=1,5
                IX=5*IXG+IXV-5
                IF(IX.LE.NX) THEN
                  VAL(IXV)=BIN(IS+8+IX)
                ELSE
                  VAL(IXV)=0D0
                ENDIF
  110         CONTINUE
              WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
  120       CONTINUE
 
C...Go to next histogram; finish.
          ELSEIF(NHI.GT.0) THEN
            CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
          ENDIF
  130   CONTINUE
 
C...Read back in histograms dumped MDUMP=1.
      ELSEIF(MDUMP.EQ.2) THEN
 
C...Read histogram number, title and range, and book.
  140   READ(LFN,5100,END=170) ID,TITLE
        READ(LFN,5200) NX,XL,XU
        CALL PYBOOK(ID,TITLE,NX,XL,XU)
        IS=INDX(ID)
 
C...Read filling statistics.
        READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
        BIN(IS+5)=DBLE(NENTRY)
 
C...Read histogram contents, in groups of five.
        DO 160 IXG=1,(NX+4)/5
          READ(LFN,5400) (VAL(IXV),IXV=1,5)
          DO 150 IXV=1,5
            IX=5*IXG+IXV-5
            IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
  150     CONTINUE
  160   CONTINUE
 
C...Go to next histogram; finish.
        GOTO 140
  170   CONTINUE
 
C...Write histogram contents in column format,
C...convenient e.g. for GNUPLOT input.
      ELSEIF(MDUMP.EQ.3) THEN
 
C...Find addresses to wanted histograms.
        NSS=0
        IF(NHI.LE.0) THEN
          NW=IHIST(1)
        ELSE
          NW=NHI
        ENDIF
        DO 180 IW=1,NW
          IF(NHI.EQ.0) THEN
            ID=IW
          ELSE
            ID=IHI(IW)
          ENDIF
          IS=INDX(ID)
          IF(IS.NE.0.AND.NSS.LT.100) THEN
            NSS=NSS+1
            ISS(NSS)=IS
          ELSEIF(NSS.GE.100) THEN
            CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
          ELSEIF(NHI.GT.0) THEN
            CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
          ENDIF
  180   CONTINUE
 
C...Check that they have common number of x bins. Fix format.
        NX=NINT(BIN(ISS(1)+1))
        DO 190 IW=2,NSS
          IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
            CALL PYERRM(8,'(PYDUMP:) different number of bins')
            RETURN
          ENDIF
  190   CONTINUE
        FORMAT='(1P,000E12.4)'
        WRITE(FORMAT(5:7),'(I3)') NSS+1
 
C...Write histogram contents; first column x values.
        DO 200 IX=1,NX
          X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
          WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
  200   CONTINUE
 
      ENDIF
 
C...Formats for output.
 5100 FORMAT(I5,5X,A60)
 5200 FORMAT(I5,1P,2D12.4)
 5300 FORMAT(I12,1P,3D12.4)
 5400 FORMAT(1P,5D12.4)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYKCUT
C...Dummy routine, which the user can replace in order to make cuts on
C...the kinematics on the parton level before the matrix elements are
C...evaluated and the event is generated. The cross-section estimates
C...will automatically take these cuts into account, so the given
C...values are for the allowed phase space region only. MCUT=0 means
C...that the event has passed the cuts, MCUT=1 that it has failed.
 
      SUBROUTINE PYKCUT(MCUT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYDAT1/,/PYINT1/,/PYINT2/
 
C...Set default value (accepting event) for MCUT.
      MCUT=0
 
C...Read out subprocess number.
      ISUB=MINT(1)
      ISTSB=ISET(ISUB)
 
C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
      TAU=VINT(21)
      YST=VINT(22)
      CTH=0D0
      IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
      TAUP=0D0
      IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
 
C...Calculate x_1, x_2, x_F.
      IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
        X1=SQRT(TAU)*EXP(YST)
        X2=SQRT(TAU)*EXP(-YST)
      ELSE
        X1=SQRT(TAUP)*EXP(YST)
        X2=SQRT(TAUP)*EXP(-YST)
      ENDIF
      XF=X1-X2
 
C...Calculate shat, that, uhat, p_T^2.
      SHAT=TAU*VINT(2)
      SQM3=VINT(63)
      SQM4=VINT(64)
      RM3=SQM3/SHAT
      RM4=SQM4/SHAT
      BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
      RPTS=4D0*VINT(71)**2/SHAT
      BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
      RM34=2D0*RM3*RM4
      RSQM=1D0+RM34
      RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
      THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
      UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
      PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
 
C...Decisions by user to be put here.
 
C...Stop program if this routine is ever called.
C...You should not copy these lines to your own routine.
      WRITE(MSTU(11),5000)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYDAT1/,/PYINT1/,/PYINT2/
 
C...Set default weight for WTXS.
      WTXS=1D0
 
C...Read out subprocess number.
      ISUB=MINT(1)
      ISTSB=ISET(ISUB)
 
C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
      TAU=VINT(21)
      YST=VINT(22)
      CTH=0D0
      IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
      TAUP=0D0
      IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
 
C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
      X1=VINT(41)
      X2=VINT(42)
      XF=X1-X2
      SHAT=VINT(44)
      THAT=VINT(45)
      UHAT=VINT(46)
      PT2=VINT(48)
 
C...Modifications by user to be put here.
 
C...Stop program if this routine is ever called.
C...You should not copy these lines to your own routine.
      WRITE(MSTU(11),5000)
      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)
      IMPLICIT INTEGER(I-N)
      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.500.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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local arrays 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)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local variables
      DOUBLE PRECISION 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...STRUCTP
C...Dummy routine, to be removed when PDFLIB is to be linked.
 
      SUBROUTINE STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
     &BOT,TOP,GLU)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
C...Local variables
      DOUBLE PRECISION XX,QQ2,P2,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+QQ2
      DNV=XX+2D0*QQ2
      USEA=XX+3D0*QQ2
      DSEA=XX+4D0*QQ2
      STR=XX+5D0*QQ2
      CHM=XX+6D0*QQ2
      BOT=XX+7D0*QQ2
      TOP=XX+8D0*QQ2
      GLU=XX+9D0*QQ2
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
     &1X,'Dummy routine STRUCTP 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)
      IMPLICIT INTEGER(I-N)
      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)
      IMPLICIT INTEGER(I-N)
      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.
C      DO 100 J=1,6
C      IDATI(J)=0
C  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. AIX.
C      CALL IDATE(IMON,IDAY,IYEAR)
C      IF(IYEAR.LT.70) THEN
C        IDATI(1)=2000+IYEAR
C      ELSEIF(IYEAR.LT.100) THEN
C        IDATI(1)=1900+IYEAR
C      ELSE
C        IDATI(1)=IYEAR 
C      ENDIF 
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, IRIX, IRIX64.
C      CALL IDATE(IMON,IDAY,IYEAR)
C      IF(IYEAR.LT.70) THEN
C        IDATI(1)=2000+IYEAR
C      ELSEIF(IYEAR.LT.100) THEN
C        IDATI(1)=1900+IYEAR
C      ELSE
C        IDATI(1)=IYEAR 
C      ENDIF 
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, SunOS.
      CALL IDATE(IDTEMP)
      IDATI(1)=IDTEMP(3)
      IDATI(2)=IDTEMP(2)
      IDATI(3)=IDTEMP(1)
      CALL ITIME(IDTEMP)
      IDATI(4)=IDTEMP(1)
      IDATI(5)=IDTEMP(2)
      IDATI(6)=IDTEMP(3)
 
      RETURN
      END