pythia-6.4.20.f

C*********************************************************************
C*********************************************************************
C*                                                                  **
C*                                                  February 2009   **
C*                                                                  **
C*                       The Lund Monte Carlo                       **
C*                                                                  **
C*                        PYTHIA version 6.4                        **
C*                                                                  **
C*                        Torbjorn Sjostrand                        **
C*                 Department of Theoretical Physics                **
C*                         Lund University                          **
C*               Solvegatan 14A, S-223 62 Lund, Sweden              **
C*                    E-mail torbjorn@thep.lu.se                    **
C*                                                                  **
C*                  SUSY and Technicolor parts by                   **
C*                         Stephen Mrenna                           **
C*                       Computing Division                         ** 
C*            Generators and Detector Simulation Group              **
C*              Fermi National Accelerator Laboratory               **
C*                 MS 234, Batavia, IL  60510, USA                  **
C*                   phone + 1 - 630 - 840 - 2556                   **
C*                      E-mail mrenna@fnal.gov                      **
C*                                                                  **
C*         New multiple interactions and more SUSY parts by         **
C*                          Peter Skands                            **
C*                  Theoretical Physics Department                  **
C*              Fermi National Accelerator Laboratory               **
C*                 MS 106, Batavia, IL  60510, USA                  **
C*                               and                                **
C*               CERN/PH, CH-1211 Geneva, Switzerland               **
C*                    phone +41 - 22 - 767 24 59                    **
C*                      E-mail skands@fnal.gov                      **
C*                                                                  **
C*         Several parts are written by Hans-Uno Bengtsson          **
C*          PYSHOW is written together with Mats Bengtsson          **
C*               PYMAEL is written by Emanuel Norrbin               **
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*  UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
C*         PYGAUS adapted from CERN library (K.S. Kolbig)           **
C*        NRQCD/colour octet production of onium by S. Wolf         **
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 (and CERN) 2008        **
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   PYCKBD   to check that BLOCK DATA has been correctly loaded   *
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   PYEVNW   ditto, for new multiple interactions scenario        *
C  S   PYSTAT   to print cross-section and other information         *
C  S   PYUPEV   to administer the generation of an LHA hard process  *
C  S   PYUPIN   to provide initialization needed for LHA input       *
C  S   PYLHEF   to produce a Les Houches Event File from run         *
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   PYEVOL   handler for pT-ordered ISR and multiple interactions *
C  S   PYSSPA   to simulate initial state spacelike showers          *
C  S   PYPTIS   to do pT-ordered initial state spacelike showers     *
C  S   PYMEMX   auxiliary to PYSSPA/PYPTIS for ME correction maximum *
C  S   PYMEWT   auxiliary to PYSSPA/.. for matrix element correction *
C  S   PYPTMI   to do pT-ordered multiple interactions               *
C  F   PYFCMP   to give companion quark x*f distribution             *
C  F   PYPCMP   to calculate momentum integral for companion quarks  *
C  S   PYUPRE   to rearranges contents of the HEPEUP commonblock     *
C  S   PYADSH   to administrate sequential final-state showers       *
C  S   PYVETO   to allow the generation of an event to be aborted    *
C  S   PYRESD   to perform resonance decays                          *
C  S   PYMULT   to generate multiple interactions - old scheme       *
C  S   PYREMN   to add on target remnants - old scheme               *
C  S   PYMIGN   to generate multiple interactions - new scheme       *
C  S   PYMIHK   to connect colours in mult. int. - new scheme        *
C  S   PYCTTR   to translate PYTHIA colour information to LHA1 tags  *
C  S   PYMIHG   to collapse two pairs of LHA1 colour tags.           *
C  S   PYMIRM   to add on target remnants in mult. int.- new scheme  *
C  S   PYFSCR   to perform final state colour reconnections - -"-    *
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   PYSGQC   auxiliary to PYSIGH for QCD processes                *
C  S   PYSGHF   auxiliary to PYSIGH for heavy flavour processes      *
C  S   PYSGWZ   auxiliary to PYSIGH for W and Z processes            *
C  S   PYSGHG   auxiliary to PYSIGH for Higgs processes              *
C  S   PYSGSU   auxiliary to PYSIGH for supersymmetry processes      *
C  S   PYSGTC   auxiliary to PYSIGH for technicolor processes        *
C  S   PYSGEX   auxiliary to PYSIGH for various exotic processes     *
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 PDFs            *
C  S   PYGBEH   to evaluate Bethe-Heitler part of photon PDFs        *
C  S   PYGDIR   to evaluate direct contribution to photon PDFs       *
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  S   PYSTBH   to evaluate matrix element for t + b + H processes   *
C  S   PYTBHB   auxiliary to PYSTBH                                  *
C  S   PYTBHG   auxiliary to PYSTBH                                  *
C  S   PYTBHQ   auxiliary to PYSTBH                                  *
C  F   PYTBHS   auxiliary to PYSTBH                                  *
C                                                                    *
C  S   PYMSIN   to initialize the supersymmetry simulation           *
C  S   PYSLHA   to interface to SUSY spectrum and decay calculators  *
C  S   PYAPPS   to determine MSSM parameters from SUGRA input        *
C  S   PYSUGI   to determine MSSM parameters using ISASUSY           *
C  S   PYFEYN   to determine MSSM Higgs parameters using FEYNHIGGS   *
C  F   PYRNMQ   to determine running squark masses                   *
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   PYRGHM   auxiliary to PYPOLE                                  *
C  S   PYGFXX   auxiliary to PYRGHM                                  *
C  F   PYFINT   auxiliary to PYPOLE                                  *
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   PYXXZ6   auxiliary for ino 3-body decays                      *
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  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   PYGAU2   copy of PYGAUS to allow two-dimensional 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   PYXDIN   to initialize Universal Extra Dimensions             *
C  S   PYUEDC   to compute UED mass radiative corrections            *
C  S   PYXUED   to compute UED cross sections                        *
C  S   PYGRAM   to generate UED G* (excited graviton) mass spectrum  *
C  F   PYGRAW   to compute UED partial widths to G*                  *
C  F   PYWDKK   to compute UED differential partial widths to G*     *
C  S   PYEICG   to calculate eigenvalues of a 4*4 complex matrix     *
C  S   PYCMQR   auxiliary to PYEICG                                  *
C  S   PYCMQ2   auxiliary to PYEICG                                  *
C  S   PYCDIV   auxiliary to PYCMQR                                  *
C  S   PYCSRT   auxiliary to PYCMQR                                  *
C  S   PYTHAG   auxiliary to PYCMQR                                  *
C  S   PYCBAL   auxiliary to PYEICG                                  *
C  S   PYCBA2   auxiliary to PYEICG                                  *
C  S   PYCRTH   auxiliary to PYEICG                                  *
C  S   PYLDCM   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
C  S   PYBKSB   auxiliary to PYSIGH, for technicolor in QCD 2 -> 2   *
C  S   PYWIDX   to calculate decay widths from within PYWIDT         *
C  S   PYRVSF   to calculate R-violating sfermion decay widths       *
C  S   PYRVNE   to calculate R-violating neutralino decay widths     *
C  S   PYRVCH   to calculate R-violating chargino decay widths       *
C  S   PYRVGL   to calculate R-violating gluino decay widths         *
C  F   PYRVSB   auxiliary to PYRVSF                                  *
C  S   PYRVGW   to calculate R-Violating 3-body widths               *
C  F   PYRVI1   auxiliary to PYRVGW, to do PS integration for res.   *
C  F   PYRVI2   auxiliary to PYRVGW, to do PS integration for LR-int.*
C  F   PYRVI3   auxiliary to PYRVGW, to do PS X integral for int.    *
C  F   PYRVG1   auxiliary to PYRVI1, general matrix element, res.    *
C  F   PYRVG2   auxiliary to PYRVI2, general matrix element, LR-int. *
C  F   PYRVG3   auxiliary to PYRVI3, to do PS Y integral for int.    *
C  F   PYRVG4   auxiliary to PYRVG3, general matrix element, int.    *
C  F   PYRVR    auxiliary to PYRVG1, Breit-Wigner                    *
C  F   PYRVS    auxiliary to PYRVG2 & PYRVG4                         *
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   PYONOF   to allow easy control of particle decay modes        *
C  S   PYTUNE   to select a predefined 'tune' for min-bias and UE    *
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   PYJURF   to find boost to string junction rest frame          *
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 m-ordered timelike parton shower evolution     *
C  S   PYPTFS   to do pT-ordered timelike parton shower evolution    *
C  F   PYMAEL   auxiliary to PYSHOW & PYPTFS: gluon emission ME's    *
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   PYSTOP   routine to handle Fortran STOP condition             *
C                                                                    *
C  S   PYKCUT   dummy routine for user kinematical cuts              *
C  S   PYEVWT   dummy routine for weighting events                   *
C  S   UPINIT   dummy routine to initialize user processes           *
C  S   UPEVNT   dummy routine to generate a user process event       *
C  S   UPVETO   dummy routine to abort event at parton level         *
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   SUGRA    dummy routine to be removed when linking with ISAJET *
C  F   VISAJE   dummy functn. to be removed when linking with ISAJET *
C  S   SSMSSM   dummy routine to be removed when linking with ISAJET *
C  S   FHSETFLAGS  dummy routine          -"-              FEYNHIGGS *
C  S   FHSETPARA   dummy routine          -"-              FEYNHIGGS *
C  S   FHHIGGSCORR dummy routine          -"-              FEYNHIGGS *
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(8000,2),BRAT(8000),KFDP(8000,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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
      COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
     &     AU(3,3),AD(3,3),AE(3,3)
      COMMON/PYLH3C/CPRO(2),CVER(2)
      CHARACTER CPRO*12,CVER*12
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
     &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
     &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
     &/PYBINS/,/PYLH3P/,/PYLH3C/
 
C...PYDAT1, containing status codes and most parameters.
      DATA MSTU/
     &   0,    0,    0, 4000,10000,  500, 8000,    0,    0,    2,
     1   6,    0,    1,    0,    0,    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, 2D0, 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,   0D0,   0D0, 0D0, 0D0, 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,   20,    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,1D0,
     4  0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
     5  0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
     5  0D0, 0D0, 0D0, 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,0.5D0,
     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, 0D0, 0D0, 0D0, 0D0, 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,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,  
     &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,  
     &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,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,  
     &7*0,3,
C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
     &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2, 
     &3*-3,0,-3,0,-3,0,-3,
     &3*0,3, 
     &25*0/
      DATA (KCHG(I,2),I=   1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,   
     &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,   
     &-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,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
     &83*0,12*1,9*0,2,3*0,25*0/
      DATA (KCHG(I,3),I=   1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,   
     &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0, 
     &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,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,
     &81*0,21*1,3*0,1,25*0/
      DATA (KCHG(I,4),I=   1, 290)/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,211,213,215,221,223,225,310,311,313,315,  
     &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,  
     &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,  
     &555,990,1103,1114,2101,2103,2112,2114,2203,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,20443,20513/      
      DATA (KCHG(I,4),I= 291, 500)/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,3000111,3000211,3000221,3000331,3000113,3000213,3000223,  
     &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,  
     &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,  
     &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,  
     &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,  
     &3000115,3000215,
     &81*0,
C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
     &6100001,6100002,6100003,6100004,6100005,6100006, 
     &5100001,5100002,5100003,5100004,5100005,5100006, 
     &6100011,6100013,6100015,
     &5100012,5100011,5100014,5100013,5100016,5100015, 
     &5100021,5100022,5100023,5100024,
     &25*0/ 
      DATA (PMAS(I,1),I=   1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,    
     &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,      
     &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,     
     &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,  
     &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0, 
     &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,   
     &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,       
     &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,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,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,     
     &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,  
     &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,       
     &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,  
     &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,   
     &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,       
     &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0, 
     &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,          
     &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,   
     &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/  
      DATA (PMAS(I,1),I= 218, 500)/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,        
     &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,      
     &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,        
     &3*9.5D0,2*250D0,
     &81*0,
C...UED
     &586.,588.,586.,588.,586.,586.,6*598.,
     &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
      DATA (PMAS(I,2),I=   1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,    
     &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,    
     &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,   
     &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,        
     &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0, 
     &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,   
     &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0, 
     &3*0D0,0.12D0,2*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,     
     &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,       
     &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,   
     &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,  
     &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,   
     &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/                       
      DATA (PMAS(I,3),I=   1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,  
     &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,           
     &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,    
     &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,    
     &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0, 
     &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,  
     &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*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, 
     &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,    
     &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,          
     &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,   
     &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,  
     &8.80013D0,13*0D0,2.54987D0,2.84456D0,
     &81*0,
C...UED
     &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
      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,7804.5D0,5*0D0,      
     &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,  
     &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*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,120*0D0,131*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.23D0, 4.17D0, 165D0,  4*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,   
     &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1, 
     &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,26*1,7*0,8*1,
     &81*0,
C...UED
     &5*1,0,5*1,0,13*1,25*0/
      DATA (MDCY(I,2),I=   1, 351)/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,420,  
     &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,    
     &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,  
     &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,  
     &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,   
     &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077, 
     &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,   
     &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,     
     &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,   
     &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,   
     &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,    
     &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471, 
     &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506, 
     &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543, 
     &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592, 
     &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162, 
     &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,  
     &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,  
     &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/ 
      DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,   
     &4214,4215,4216,4296,4322,
     &81*0,
C...UED
     %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
     &5031,5032,5033,
     &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
     &25*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,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2, 
     &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,  
     &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,  
     &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,45,24,45,24,   
     &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,   
     &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,    
     &3*22,15,12,2*7,7*0,6*1,26,30,
     &81*0,
C...UED
     &6*2,6*3,9*1,24,1,18,6,25*0/                                 
      DATA (MDME(I,1),I=   1,8000)/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,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,    
     &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,     
     &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1, 
     &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,  
     &5*-1,3*1,-1,
     &649*0,
C...UED
     &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
     &1,24*1,2912*0/
      DATA (MDME(I,2),I=   1,8000)/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,16*0,62*53,8*32,13*0,62*53,4*32,5*0,     
     &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,    
     &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,2404*53,4*32,   
     &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,   
     &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,     
     &16*32,
C...UED
     &653*0,30*0,9*0,12*0,37*0,2912*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.153995D0,0.11942D0,0.153984D0,0.119259D0,      
     &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,     
     &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0, 
     &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,         
     &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,    
     &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0, 
     &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,    
     &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,     
     &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,   
     &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,          
     &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,         
     &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/ 
      DATA (BRAT(I)  ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0, 
     &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,         
     &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0, 
     &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,     
     &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,        
     &0.069959D0,0D0,2*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/     
      DATA (BRAT(I)  ,I= 656, 831)/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,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,     
     &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,      
     &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0, 
     &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,        
     &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0, 
     &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,       
     &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,  
     &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,     
     &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,   
     &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,      
     &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,     
     &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,    
     &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,     
     &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,       
     &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,  
     &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0, 
     &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/      
      DATA (BRAT(I)  ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,    
     &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0, 
     &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,     
     &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,        
     &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,   
     &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,       
     &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,    
     &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,  
     &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,       
     &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,          
     &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,         
     &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,      
     &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,    
     &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,   
     &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,         
     &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,       
     &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, 
     &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,    
     &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,    
     &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/        
      DATA (BRAT(I)  ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,     
     &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,   
     &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,   
     &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,   
     &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,        
     &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0, 
     &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,   
     &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,  
     &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,      
     &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,     
     &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,       
     &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,          
     &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,   
     &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,     
     &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,          
     &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,         
     &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,       
     &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,  
     &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,    
     &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/        
      DATA (BRAT(I)  ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,     
     &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,  
     &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,    
     &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,   
     &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,      
     &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,      
     &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,      
     &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,      
     &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,       
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,  
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,      
     &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/      
      DATA (BRAT(I)  ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,   
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,      
     &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,     
     &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,    
     &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,      
     &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,  
     &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,  
     &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,      
     &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,      
     &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,       
     &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0, 
     &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,   
     &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,       
     &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/       
      DATA (BRAT(I)  ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,      
     &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,      
     &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,   
     &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,      
     &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,     
     &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,      
     &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,           
     &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,  
     &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,       
     &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,           
     &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0, 
     &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,     
     &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,    
     &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0, 
     &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0, 
     &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,           
     &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,     
     &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0, 
     &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0, 
     &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/     
      DATA (BRAT(I)  ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,    
     &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,           
     &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,           
     &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,     
     &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0, 
     &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,           
     &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,   
     &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,          
     &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,          
     &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0, 
     &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,           
     &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,           
     &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,           
     &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,       
     &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,       
     &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,           
     &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,     
     &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,    
     &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,         
     &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/           
      DATA (BRAT(I)  ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,    
     &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,     
     &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0, 
     &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0, 
     &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,   
     &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,      
     &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,          
     &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0, 
     &2*0.011947D0,0.011946D0,0D0,
     &649*0.D0,
C....UED
     &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
     &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, 
     &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
     &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
     &9*1.D0,              
     &24*0.0416667,        
     &1.,                  
     &3*0.D0,6*0.08333D0, 
     &3*0.D0,6*0.08333D0,
     &6*0.166667D0,        
     &2912*0.D0/
      DATA (KFDP(I,1),I=   1, 377)/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,24,  
     &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,      
     &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/       
      DATA (KFDP(I,1),I= 378, 580)/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,13,15,17,21,2*22,23,  
     &24,23,25,24,37,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,1,2,3,4,5,6,11,13,15,2,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/ 
      DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,   
     &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,   
     &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,    
     &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,  
     &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,   
     &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,   
     &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,  
     &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,      
     &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421, 
     &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311, 
     &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,   
     &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311, 
     &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,      
     &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,  
     &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,   
     &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,    
     &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,     
     &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,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/  
      DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,    
     &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,  
     &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,   
     &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,  
     &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,    
     &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13, 
     &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,   
     &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,     
     &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,     
     &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,   
     &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,   
     &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,    
     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,   
     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16, 
     &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,     
     &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,     
     &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,  
     &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,   
     &-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/     
      DATA (KFDP(I,1),I=1403,1713)/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,3*-12,3*-14,3*-16,12,11,  
     &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,   
     &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,  
     &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,        
     &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,        
     &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,  
     &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,   
     &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/  
      DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,     
     &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,      
     &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,  
     &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,   
     &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,  
     &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,  
     &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,      
     &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012, 
     &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,        
     &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,  
     &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,     
     &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,  
     &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,        
     &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,  
     &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,     
     &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,  
     &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,        
     &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,  
     &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,      
     &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/       
      DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,   
     &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,      
     &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,  
     &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,     
     &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11, 
     &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,   
     &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,   
     &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,   
     &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,   
     &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,   
     &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,  
     &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12, 
     &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,   
     &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,   
     &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,   
     &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,   
     &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,   
     &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,   
     &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,   
     &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/ 
      DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,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,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,   
     &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,   
     &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
     &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,   
     &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
     &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,   
     &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
     &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/   
      DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,  
     &-4,4,-6,6,-6,6,-6,6,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,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,   
     &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,  
     &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,   
     &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12, 
     &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14, 
     &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, 
     &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16, 
     &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, 
     &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,    
     &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,      
     &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,       
     &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,      
     &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,       
     &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/      
      DATA (KFDP(I,1),I=2893,3182)/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,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,   
     &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,   
     &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
     &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,   
     &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
     &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,   
     &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
     &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,   
     &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,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/      
      DATA (KFDP(I,1),I=3183,3459)/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,-12, 
     &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,   
     &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,   
     &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,   
     &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,   
     &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,   
     &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,   
     &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,   
     &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,  
     &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,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/      
      DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,   
     &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,      
     &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, 
     &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,    
     &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,   
     &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,     
     &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, 
     &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14, 
     &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16, 
     &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16, 
     &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1, 
     &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,  
     &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,        
     &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,  
     &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,   
     &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,        
     &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,        
     &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,      
     &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,  
     &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/   
      DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,     
     &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,        
     &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,       
     &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,       
     &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12, 
     &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,    
     &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,        
     &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,   
     &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,     
     &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,   
     &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,   
     &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,   
     &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,   
     &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,        
     &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,  
     &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,  
     &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4, 
     &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,   
     &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18, 
     &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/     
      DATA (KFDP(I,1),I=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,  
     &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,   
     &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,      
     &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,   
     &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23, 
     &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15, 
     &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,   
     &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,    
     &-11,-13,-15,-17,
     &649*0,
C...UED
     &5100023,5100022,5100023,5100022,5100023,5100022,
     &5100023,5100022,5100023,5100022,5100023,5100022, 
     &5100023,-5100024,5100022,5100023,5100024,5100022,
     &5100023,-5100024,5100022,5100023,5100024,5100022,
     &5100023,-5100024,5100022,5100023,5100024,5100022, 
     &9*5100022, 
     &6100001,6100002,6100003,6100004,6100005,6100006,
     &5100001,5100002,5100003,5100004,5100005,5100006,
     &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
     &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006, 
     &39, 
     &6100011,6100013,6100015,
     &5100011,5100013,5100015,
     %5100012,5100014,5100016,
     &-6100011,-6100013,-6100015,
     &-5100011,-5100013,-5100015,
     %-5100012,-5100014,-5100016,
     &-5100011,-5100013,-5100015,
     &5100012,5100014,5100016,
     &2912*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, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,    
     &-24,2*25,-37,-24,3*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,2*25,-37,-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,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,-3,-4,-5,-6/ 
      DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,   
     &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211, 
     &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,   
     &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,  
     &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,    
     &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,   
     &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223, 
     &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,    
     &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,   
     &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,    
     &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211, 
     &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,    
     &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310, 
     &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111, 
     &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,       
     &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,    
     &-11,-13,-82,22,-82,6*-11,6*-13,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/   
      DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,   
     &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,  
     &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,     
     &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,   
     &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,   
     &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,  
     &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211, 
     &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,   
     &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,    
     &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211, 
     &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,   
     &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,  
     &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,  
     &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,  
     &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,  
     &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,  
     &4,1,3,11,13,15,1,4,3,4,1,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/ 
      DATA (KFDP(I,2),I=1353,1815)/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,2*1,3,5,  
     &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,   
     &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,     
     &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,  
     &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3, 
     &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3, 
     &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,  
     &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/  
      DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5, 
     &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5, 
     &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, 
     &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3, 
     &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,   
     &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15, 
     &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,  
     &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,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3, 
     &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2, 
     &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5, 
     &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4, 
     &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1, 
     &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,    
     &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,   
     &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, 
     &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, 
     &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, 
     &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, 
     &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/ 
      DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,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,-13,13,-13,13,-13,13,    
     &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,   
     &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, 
     &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, 
     &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, 
     &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, 
     &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3, 
     &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,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,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,     
     &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,  
     &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,   
     &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,   
     &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/  
      DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,  
     &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1, 
     &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,  
     &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,-13,   
     &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,   
     &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,  
     &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6, 
     &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3, 
     &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2, 
     &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5, 
     &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36, 
     &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,  
     &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36, 
     &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,    
     &-15,1,-1,3,-3,-37,37,-37,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/  
      DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,  
     &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,    
     &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,   
     &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,  
     &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2, 
     &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5, 
     &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4, 
     &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1, 
     &1,-1,1,-3,3,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,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,  
     &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,     
     &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,  
     &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3, 
     &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,   
     &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,  
     &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,   
     &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,   
     &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/     
      DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5, 
     &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,   
     &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,   
     &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,  
     &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,  
     &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,  
     &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,  
     &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,     
     &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,  
     &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,  
     &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,  
     &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,  
     &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,   
     &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,   
     &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,   
     &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11, 
     &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,  
     &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,     
     &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,     
     &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/   
      DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,   
     &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,   
     &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,   
     &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17, 
     &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,  
     &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,  
     &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24, 
     &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,        
     &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,  
     &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,    
     &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,      
     &649*0,
C...UED     
     &1,1,2,2,3,3,4,4,5,5,6,6, 
     &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
     &11,13,15,12,11,14,13,16,15, 
     &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
     &1,2,3,4,5,6,1,2,3,4,5,6, 
     &22, 
     &-11,-13,-15,-11,-13,-15,-12,-14,-16,
     &11,13,15,11,13,15,12,14,16,
     &12,14,16,-11,-13,-15, 
     &2912*0/
      DATA (KFDP(I,3),I=   1,1021)/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,   
     &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,    
     &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,    
     &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,  
     &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,   
     &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,   
     &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,    
     &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,  
     &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,   
     &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,    
     &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0, 
     &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,      
     &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,  
     &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,    
     &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,  
     &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,    
     &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,   
     &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/  
      DATA (KFDP(I,3),I=1022,2223)/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,199*0,2*5,210*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,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,  
     &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, 
     &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, 
     &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, 
     &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,   
     &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, 
     &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,   
     &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ 
      DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,  
     &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, 
     &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, 
     &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,   
     &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,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,11,-11,13,-13,15,-15, 
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,  
     &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, 
     &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, 
     &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, 
     &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,   
     &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2, 
     &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,  
     &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11, 
     &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1, 
     &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,   
     &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,   
     &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/   
      DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, 
     &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,  
     &-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,11,-11,13,-13,15,-15, 
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,  
     &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, 
     &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, 
     &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, 
     &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,   
     &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,   
     &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,    
     &-11,-13,-15,-12,-14,-16,-1,-3,-5,-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, 
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,   
     &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1, 
     &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, 
     &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3, 
     &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ 
      DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,  
     &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,   
     &-5,5,-3,3,-5,5,-5,5,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,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,    
     &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,  
     &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,   
     &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,   
     &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,   
     &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,   
     &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,  
     &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4, 
     &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4, 
     &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4, 
     &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/    
      DATA (KFDP(I,4),I=   1,8000)/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,402*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,6516*0/                                      
      DATA (KFDP(I,5),I=   1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,     
     &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,     
     &3*111,-211,111,7193*0/                                            
 
C...PYDAT4, with particle names (character strings).
      DATA (CHAF(I,1),I=   1, 202)/'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',6*' ','Z''0','Z"0',   
     &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',     
     &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',     
     &'junction',' ','system','cluster','string','indep.','CMshower',   
     &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',  
     &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',     
     &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi', 
     &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',     
     &'D*_2s+','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','pomeron','dd_1','Delta-','ud_0','ud_1','n0',  
     &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',   
     &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',    
     &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',       
     &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',  
     &'Sigma_c+','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++'/       
      DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',            
     &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',  
     &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+', 
     &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',    
     &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',     
     &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',   
     &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',          
     &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',            
     &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',    
     &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1', 
     &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',   
     &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',  
     &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',      
     &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',       
     &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',       
     &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',         
     &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',          
     &'~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','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/      
      DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',      
     &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',        
     &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',     
     &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',         
     &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',         
     &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',        
     &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
     &81*' ',
C...UED    
     &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
     &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
     &'e*_S-','mu*_S-','tau*_S-',
     &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
     &'g*','gamma*','Z*0','W*+',25*' '/               
      DATA (CHAF(I,2),I=   1, 205)/'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-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',  
     &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ', 
     &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',  
     &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',      
     &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',   
     &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',   
     &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',    
     &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+', 
     &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',        
     &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',         
     &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',     
     &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar', 
     &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',            
     &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',      
     &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',               
     &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',   
     &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/    
      DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',   
     &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',   
     &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',             
     &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',        
     &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',  
     &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',  
     &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',           
     &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',       
     &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+', 
     &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',                 
     &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',  
     &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',         
     &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',       
     &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',         
     &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',           
     &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',          
     &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',        
     &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',  
     &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',      
     &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/       
      DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',              
     &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar', 
     &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',            
     &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',     
     &81*' ',
C...UED
     &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
     &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
     &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
     &'nu*_eDbar','e*_Dbar+',
     &'nu*_muDbar','mu*_Dbar+',
     &'nu*_tauDbar','tau*_Dbar+',
     &'g*','gamma*','Z*0','W*-',25*' '/            
 
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  2,    1,    3,    7,    3,    1,    1,    0,    1,    0,
     5  7,    1,    3,    1,    5,    1,    1,    5,    1,    7,
     6  2,    3,    2,    2,    1,    5,    2,    3,    0,    0,
     7  1,    1,    0,    0,    0,    0,    0,    0,    0,    0,
     8  1,    4,  100,    1,    1,    2,    4,    1,    1,    0,
     9  1,    3,    1,    3,    1,    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,  100,    0,    0,   10,    0,
     3  0,    4,    0,    1,    0,    0,    0,    0,    0,    0,
     4  0,    0,    0,    0,    0,    1,    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,  420, 2009,   02,   20,    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,1.0D0,0.70D0,0.006D0,0D0,
     4  0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
     5  10*0D0,
     6  0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
     7  4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
     8  1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
     8  0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
     9  2.0D0,0.40D0,5.0D0,1.0D0,0.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, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
     1  2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
     2  1.0D0,  0.4D0, 8*0D0,
     3  0.01D0, 9*0D0,
     4  1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0, 
     4  9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
     5  0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 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, 1.0D4, 1.0D4, 6*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, 9*-2, 9*2, 21*-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,    2,    2,    2,
     8  2,    2,    2,    2,    2,    2,    2,    2,   -2,   -2,
     9  1,    1,    2,    2,    2, 5*-2,
     &  5,    5, 18*-2,
     2  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     3  2,    2,    2,    2,    2,    2,    2,    2,    2, 21*-2,
     6  2,    2,    2,    2,    2,    2,    2,    2,    2,    2,
     7  2,    2,    2,    2,    2,    2,    2,    2,    2, 21*-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,   41,    0,   42,    0,
     4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 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,   42,    0,   42,   42,   42,   42,   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,   21,   35,    0,   35,   21,   35,
     8  36,    6,   36,    6,   21,   36,    0,   36,   21,   36,
     9  3000113, 0, 3000213, 0, 3000223, 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,240)/
     &  1000011,   1000011,   2000011,   2000011,   1000011,
     &  2000011,   1000013,   1000013,   2000013,   2000013,
     &  1000013,   2000013,   1000015,   1000015,   2000015,
     &  2000015,   1000015,   2000015,   1000011,   1000012,
     1  1000015,   1000016,   2000015,   1000016,   1000012,
     1  1000012,   1000016,   1000016,         0,         0,
     1  1000022,   1000022,   1000023,   1000023,   1000025,
     1  1000025,   1000035,   1000035,   1000022,   1000023,
     2  1000022,   1000025,   1000022,   1000035,   1000023,
     2  1000025,   1000023,   1000035,   1000025,   1000035,
     2  1000024,   1000024,   1000037,   1000037,   1000024,
     2  1000037,   1000022,   1000024,   1000023,   1000024,
     3  1000025,   1000024,   1000035,   1000024,   1000022,
     3  1000037,   1000023,   1000037,   1000025,   1000037,
     3  1000035,   1000037,   1000021,   1000022,   1000021,
     3  1000023,   1000021,   1000025,   1000021,   1000035/
      DATA ((KFPR(I,J),J=1,2),I=241,280)/
     4  1000021,   1000024,   1000021,   1000037,   1000021,
     4  1000021,   1000021,   1000021,         0,         0,
     4  1000002,   1000022,   2000002,   1000022,   1000002,
     4  1000023,   2000002,   1000023,   1000002,   1000025,
     5  2000002,   1000025,   1000002,   1000035,   2000002,
     5  1000035,   1000001,   1000024,   2000005,   1000024,
     5  1000001,   1000037,   2000005,   1000037,   1000002,
     5  1000021,   2000002,   1000021,         0,         0,
     6  1000006,   1000006,   2000006,   2000006,   1000006,
     6  2000006,   1000006,   1000006,   2000006,   2000006,
     6        0,         0,         0,         0,         0,
     6        0,         0,         0,         0,         0,
     7  1000002,   1000002,   2000002,   2000002,   1000002,
     7  2000002,   1000002,   1000002,   2000002,   2000002,
     7  1000002,   2000002,   1000002,   1000002,   2000002,
     7  2000002,   1000002,   1000002,   2000002,   2000002/
      DATA ((KFPR(I,J),J=1,2),I=281,350)/
     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,
     &       37,        37,      18*0,
C...UED: 311-319
     &  5100021,   5100021, 
     &  5100002,   5100021, 
     &  5100002,   5100001,
     &  5100002,  -5100002, 
     &  5100002,  -5100002,
     &  5100002,  -6100001,
     &  5100002,  -5100001,
     &  5100002,   6100001,
     &  5100001,  -5100001,
     &  42*0,
     4  9900041,         0,   9900042,         0,   9900041,
     4       11,   9900042,        11,   9900041,        13,
     4  9900042,        13,   9900041,        15,   9900042,
     4       15,   9900041,   9900041,   9900042,   9900042/
      DATA ((KFPR(I,J),J=1,2),I=351,400)/
     5  9900041,         0,   9900042,         0,   9900023,
     5        0,   9900024,         0,         0,         0,
     5        0,         0,         0,         0,         0,
     5        0,         0,         0,         0,         0,
     6       24,        24,        24,   3000211,   3000211,
     6  3000211,        22,   3000111,        22,   3000221,
     6       23,   3000111,        23,   3000221,        24,
     6  3000211,         0,         0,        24,        23,
     7       24,   3000111,   3000211,        23,   3000211,
     7  3000111,        22,   3000211,        23,   3000211,
     7       24,   3000111,        24,   3000221,        22,
     7       24,        22,        23,        23,        23,
     8   0,    0,    0,    0,   21,   21,    0,   21,    0,    0,
     8  21,   21,    0,    0,    0,    0,    0,    0,    0,    0,
     9  5000039,         0,   5000039,         0,        21,
     9  5000039,         0,   5000039,        21,   5000039,
     9     10*0/
      DATA ((KFPR(I,J),J=1,2),I=401,500)/
     &  37,    6,   37,    6,    36*0,
     2      443,        21,   9900443,        21,   9900441,
     2       21,   9910441,        21,         0,   9900443,
     2        0,   9900441,         0,   9910441,        21,
     2  9900443,        21,   9900441,        21,   9910441,
     3 10441, 21, 20443,  21,  445,   21,    0, 10441,   0, 20443,
     3   0,  445,   21, 10441,  21, 20443,  21,  445,  42*0,
     6      553,        21,   9900553,        21,   9900551,
     6       21,   9910551,        21,         0,   9900553,
     6        0,   9900551,         0,   9910551,        21,
     6  9900553,        21,   9900551,        21,   9910551,
     7 10551, 21, 20553,  21,  555,   21,    0, 10551,   0, 20553,
     7   0,  555,   21, 10551,  21, 20553,  21,  555, 42*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,4*1,   
     &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
     &81*0,21*1,4*1,25*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'q + qbar -> 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_tc             ',  '                            ',
     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'q + qbar -> g + H0          ',  'q + g -> q + H0             ',
     8'g + g -> g + H0             ',  'g + g -> Q + Qbar + A0      ',
     8'q + qbar -> Q + Qbar + A0   ',  'q + qbar -> g + A0          ',
     8'q + g -> q + A0             ',  'g + g -> g + A0             ',
     9'f + fbar -> rho_tc0         ',  'f + f'' -> rho_tc+/-         ',
     9'f + fbar -> omega_tc0      ',  '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-         ',
     &9*'                          ',  'g + g -> g* + g*            ',
     &'q + g -> q*_D + g*          ',  'qi + qj -> q*_Di + q*_Dj    ',
     &'g + g -> q*_D + q*_Dbar     ',  'q  + qbar -> q*_D + q*_Dbar ',
     &'qi + qbarj -> q*Di + q*Sbarj',  'qi + qjbar -> q*Di + q*Dbarj',
     &'qi + qj -> q*_Di + q*_Sj    ',  'qi + qibar -> q*Dj + q*Dbarj',
     &21*'                          '/
      DATA (PROC(I),I=341,380)/
     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++/-- ','f + fbar -> Z_R0            ',
     5'f + fbar'' -> W_R+/-         ',5*'                            ',
     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'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
     7'f + fbar -> Z0 Z0 (ETC)     '/
      DATA (PROC(I),I=381,420)/
     8'f + f'' -> f + f'' (ETC)      ','f + fbar -> f'' + fbar'' (ETC)',
     8'f + fbar -> g + g (ETC)     ',  'f + g -> f + g (ETC)        ',
     8'g + g -> f + fbar (ETC)     ',  'g + g -> g + g (ETC)        ',
     8'q + qbar -> Q + Qbar (ETC)  ',  'g + g -> Q + Qbar (ETC)     ',
     8'                            ',  '                            ',
     9'f + fbar -> G*              ',  'g + g -> G*                 ',
     9'q + qbar -> g + G*          ',  'q + g -> q + G*             ',
     9'g + g -> g + G*             ',  '                            ',
     9 4*'                         ',
     &'g + g -> t + b + H+/-       ',  'q + qbar -> t + b + H+/-    ',
     & 18*'                            '/
      DATA (PROC(I),I=421,460)/
     2'g + g  -> cc~[3S1(1)] + g   ',  'g + g  -> cc~[3S1(8)] + g   ',
     2'g + g  -> cc~[1S0(8)] + g   ',  'g + g  -> cc~[3PJ(8)] + g   ',
     2'g + q  -> q + cc~[3S1(8)]   ',  'g + q  -> q + cc~[1S0(8)]   ',
     2'g + q  -> q + cc~[3PJ(8)]   ',  'q + q~ -> g + cc~[3S1(8)]   ',
     2'q + q~ -> g + cc~[1S0(8)]   ',  'q + q~ -> g + cc~[3PJ(8)]   ',
     3'g + g  -> cc~[3P0(1)] + g   ',  'g + g  -> cc~[3P1(1)] + g   ',
     3'g + g  -> cc~[3P2(1)] + g   ',  'q + g  -> q + cc~[3P0(1)]   ',
     3'q + g  -> q + cc~[3P1(1)]   ',  'q + g  -> q + cc~[3P2(1)]   ',
     3'q + q~ -> g + cc~[3P0(1)]   ',  'q + q~ -> g + cc~[3P1(1)]   ',
     3'q + q~ -> g + cc~[3P2(1)]   ',
     3     21 *'                            '/
      DATA (PROC(I),I=461,500)/
     6'g + g  -> bb~[3S1(1)] + g   ',  'g + g  -> bb~[3S1(8)] + g   ',
     6'g + g  -> bb~[1S0(8)] + g   ',  'g + g  -> bb~[3PJ(8)] + g   ',
     6'g + q  -> q + bb~[3S1(8)]   ',  'g + q  -> q + bb~[1S0(8)]   ',
     6'g + q  -> q + bb~[3PJ(8)]   ',  'q + q~ -> g + bb~[3S1(8)]   ',
     6'q + q~ -> g + bb~[1S0(8)]   ',  'q + q~ -> g + bb~[3PJ(8)]   ',
     7'g + g  -> bb~[3P0(1)] + g   ',  'g + g  -> bb~[3P1(1)] + g   ',
     7'g + g  -> bb~[3P2(1)] + g   ',  'q + g  -> q + bb~[3P0(1)]   ',
     7'q + g  -> q + bb~[3P1(1)]   ',  'q + g  -> q + bb~[3P2(1)]   ',
     7'q + q~ -> g + bb~[3P0(1)]   ',  'q + q~ -> g + bb~[3P1(1)]   ',
     7'q + q~ -> g + bb~[3P2(1)]   ',
     7     21 *'                            '/
 
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,  0,  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  10*0D0,  
     4  0D0,1D0,8*0D0,  
     5  49*0D0/
C...Initial values for R-violating SUSY couplings.
C...Should not be changed here. See PYMSIN.
      DATA RVLAM/27*0D0/
      DATA RVLAMP/27*0D0/
      DATA RVLAMB/27*0D0/
 
C...Technicolor switches and parameters
      DATA ITCM/0,
     &  4,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     1  89*0/
      DATA RTCM/0D0,
     &  82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
     1  .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
     2  .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
     3  .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
     4  1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
     4  200D0, 48*0D0/
 
C...UED switches and parameters.
C... IUED(0) empty IUED vector element
C... IUED(1) UED ON(=1)/OFF(=0) switch
C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
C... IUED(4) N the number of large extra dimensions
C... IUED(5) Selects whether the code takes Lambda (=0)
C...         or Lambda*R (=1) as input.
C... IUED(6) With radiative corrections to the masses (=1)
C...         or without (=0)
C...
C... RUED(0) empty RUED vector element
C... RUED(1) RINV (1/R) the curvature of the extra dimension
C... RUED(2) XMD the (4+N)-dimensional Planck scale
C... RUED(3) LAMUED (Lambda cutoff scale)
C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
C...
      DATA IUED/0,0,0,5,6,0,1,93*0/
      DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/

C...Data for histogramming routines.
      DATA IHIST/1000,20000,55,1/
      DATA INDX/1000*0/

C...Data for SUSY Les Houches Accord.
      DATA CPRO/'PYTHIA      ','PYTHIA      '/
      DATA CVER/'6.4         ','6.4         '/
      DATA MODSEL/200*0/
      DATA PARMIN/100*0D0/
      DATA RMSOFT/101*0D0/
      DATA AU/9*0D0/
      DATA AD/9*0D0/
      DATA AE/9*0D0/
 
      END
 
C*********************************************************************
 
C...PYCKBD
C...Check that BLOCK DATA PYDATA has been loaded.
C...Should not be required, except that some compilers/linkers
C...are pretty buggy in this respect.
 
      SUBROUTINE PYCKBD
 
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(8000,2),BRAT(8000),KFDP(8000,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...Check a few variables to see they have been sensibly initialized.
      IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
     &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
     &MSTP(1).GT.5) THEN
C...If not, abort the run right away.
        WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
        WRITE(*,*) 'The program execution is stopped now!'
        CALL PYSTOP(8)
      ENDIF
 
      RETURN
      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(8000,2),BRAT(8000),KFDP(8000,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)
          CALL PYSTOP(9)
        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('3MOM','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)
            CALL PYSTOP(9)
          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...Store HEPEVT commonblock size (for interfacing issues).
      MSTU(8)=NMXHEP
 
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 150 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
  120       IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
     &      THEN
              IMO1=IMO1-1
              GOTO 120
            ENDIF
            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
  130       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 130
            KC=PYCOMP(K(I1,2))
            IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
            IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
            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 140 I1=JDAHEP(1,I),JDAHEP(2,I)
              I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
              JDAHEP(1,I2)=I
  140       CONTINUE
          ENDIF
          IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
          I1=JMOHEP(1,I)
          IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
          IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
          IF(JDAHEP(1,I1).EQ.0) THEN
            JDAHEP(1,I1)=I
          ELSE
            JDAHEP(2,I1)=I
          ENDIF
  150   CONTINUE
        DO 160 I=1,NHEP
          IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
          IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
  160   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 190 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 170 J=1,5
            P(I,J)=PHEP(J,I)
  170     CONTINUE
          DO 180 J=1,4
            V(I,J)=VHEP(J,I)
  180     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
  190   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(8000,2),BRAT(8000),KFDP(8000,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)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
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/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
      COMMON/W50512/QCDL4,QCDL5
      SAVE /W50511/,/W50512/
      DOUBLE PRECISION VALUE(20),TMAS,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...Check that BLOCK DATA PYDATA has been loaded.
      CALL PYCKBD
 
C...Reset MINT and VINT arrays. Write headers.
      MSTI(53)=0
      DO 100 J=1,400
        MINT(J)=0
        VINT(J)=0D0
  100 CONTINUE
      IF(MSTU(12).NE.12345) CALL PYLIST(0)
      IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
 
C...Reset error counters.
      MSTU(23)=0
      MSTU(27)=0
      MSTU(30)=0
 
C...Reset processes that should not be on.
      MSUB(96)=0
      MSUB(97)=0
 
C...Select global FSR/ISR/UE parameter set = 'tune' 
C...See routine PYTUNE for details
      IF (MSTP(5).NE.0) THEN
        MSTP5=MSTP(5)
        CALL PYTUNE(MSTP5)
      ENDIF

C...Call user process initialization routine.
      IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
        MSEL=0
        CALL UPINIT
        MSEL=0
      ENDIF
 
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.AND.NFL.EQ.5) THEN
          ALAM=QCDL5
          NF=5
        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 UED masses and widths
      IF (IUED(1).EQ.1) CALL PYXDIN

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)).GT.100.OR.IABS(MINT(12)).GT.100)) 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)).GT.100.OR.IABS(MINT(12)).GT.100)) 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)).GT.100.OR.IABS(MINT(12)).GT.100)) 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)).GT.100.OR.IABS(MINT(12)).GT.100)) 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))
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
            WRITE(MSTU(11),5300) ISUB
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
            WRITE(MSTU(11),5400) ISUB
            CALL PYSTOP(1)
          ELSEIF(MSUB(ISUB).EQ.1) THEN
            MINT(48)=MINT(48)+1
          ENDIF
  130   CONTINUE
 
C...Stop or raise warning flag if no subprocesses on.
        IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
          IF(MSTP(127).NE.1) THEN
            WRITE(MSTU(11),5500)
            CALL PYSTOP(1)
          ELSE
            WRITE(MSTU(11),5700)
            MSTI(53)=1
          ENDIF
        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) THEN
          PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
          IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
     &    ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
          IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
            MINT(35)=1
            CALL PYMULT(1)
            MINT(35)=3
            CALL PYMIGN(1)
          ENDIF
        ENDIF
 
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
        IF(MSTP(127).NE.1) THEN
          WRITE(MSTU(11),5500)
          CALL PYSTOP(1)
        ELSE
          WRITE(MSTU(11),5700)
          MSTI(53)=1
        ENDIF
      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('*'))
 5700 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution will stop if you try to generate events.')
 
      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
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      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(8000,2),BRAT(8000),KFDP(8000,5)
      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)
      SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
C...Local array.
      DIMENSION VTX(4)
 
C...Optionally let PYEVNW do the whole job.
      IF(MSTP(81).GE.20) THEN
        CALL PYEVNW
        RETURN
      ENDIF
 
C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        CALL PYSTOP(1)
      ENDIF
 
C...Initial values for some counters.
      MSTU(1)=0
      MSTU(2)=0
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
      MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
      NCT=0
      MINT(33)=0
 
C...Let called routines know call is from PYEVNT (not PYEVNW).
      MINT(35)=1
      IF (MSTP(81).GE.10) MINT(35)=2
 
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 270 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 280
        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(39)=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 260
 
C...Loopback point if PYPREP fails, especially for junction topologies.
        NPREP=0
        MNT31S=MINT(31)
  110   NPREP=NPREP+1
        MINT(31)=MNT31S
 
        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)
  120     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 140
 
C...Reset statistics on activity in event.
        DO 130 J=351,359
          MINT(J)=0
          VINT(J)=0D0
  130   CONTINUE
 
C...Showering of initial state partons (optional).
          NFIN=N
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
     &    CALL PYSSPA(IPU1,IPU2)
          PARJ(81)=ALAMSV
          IF(MINT(51).EQ.1) GOTO 100

C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
          IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
            PTMAX=0.5*SQRT(PARP(71))*VINT(55)
            CALL PYPTFS(3,PTMAX,0D0,PTGEN)
          ENDIF
 
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(ISET(ISUB).EQ.11) THEN
            CALL PYADSH(NFIN)
          ENDIF
          PARJ(81)=ALAMSV
 
C...Allow possibility for user to abort event generation.
          IVETO=0
          IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
          IF(IVETO.EQ.1) GOTO 100
 
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 - PYTHIA 6.3 intermediate style.
  140     IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
            IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
            CALL PYMIGN(6)
            IF(MINT(51).EQ.1) GOTO 100
            MINT(53)=N
 
C...Beam remnant flavour and colour assignments - new scheme.
            CALL PYMIHK
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
 
C...Primordial kT and beam remnant momentum sharing - new scheme.
            CALL PYMIRM
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
            IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
 
C...Multiple interactions - PYTHIA 6.2 style.
          ELSEIF(MINT(111).NE.12) THEN
            IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
              CALL PYMULT(6)
              MINT(53)=N
            ENDIF
 
C...Hadron remnants and primordial kT.
            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
          ENDIF
 
        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.
        MINT(54)=N
        IF(MSTP(111).GE.1) THEN
          NFIX=N
          DO 150 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
              KCA=PYCOMP(K(I,2))
              IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
                CALL PYRESD(I)
                IF(MINT(51).EQ.1) GOTO 100
              ENDIF
            ENDIF
  150     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 160 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)
  160     CONTINUE
          NRECAL=N
        ENDIF
 
C...Colour reconnection before string formation
        IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)

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(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
          MSTU(24)=0
          GOTO 100
        ENDIF
        IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
        IF (MINT(51).EQ.1) GOTO 100
        IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
          DO 190 I=MINT(84)+1,N
            IF(K(I,2).EQ.94) THEN
              DO 180 I1=I+1,MIN(N,I+10)
                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 170 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
  170               CONTINUE
                    IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
                  ENDIF
                ENDIF
  180         CONTINUE
            ENDIF
  190     CONTINUE
          CALL PYEDIT(12)
          CALL PYEDIT(14)
          IF(MSTP(125).EQ.0) CALL PYEDIT(15)
          IF(MSTP(125).EQ.0) MINT(4)=0
          DO 210 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 200 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
  200         CONTINUE
            ENDIF
  210     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 220 J=1,4
            VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
     &      SIN(PARU(2)*PYR(0))
  220     CONTINUE
          DO 240 I=MINT(83)+1,N
            DO 230 J=1,4
              V(I,J)=V(I,J)+VTX(J)
  230       CONTINUE
  240     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 250 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)
  250     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.
  260   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)
  270 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.
  280 CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)
 
C...Error messages
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 
      RETURN
      END
 
C*********************************************************************
 
C...PYEVNW
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines for the new multiple interactions and
C...showering framework.
 
      SUBROUTINE PYEVNW
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      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(8000,2),BRAT(8000),KFDP(8000,5)
      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/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
     &     /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
C...Local arrays.
      DIMENSION VTX(4)
 
C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        CALL PYSTOP(1)
      ENDIF
 
C...Initial values for some counters.
      MSTU(1)=0
      MSTU(2)=0
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
      MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCT/.
      NCT=0
      MINT(33)=0
C...Zero counters for pT-ordered showers (failsafe)
      NPART=0
      NPARTD=0
 
C...Let called routines know call is from PYEVNW (not PYEVNT).
      MINT(35)=3
 
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 300 IPILE=1,NPILE
        IF(MINT(84)+100.GE.MSTU(4)) THEN
          CALL PYERRM(11,
     &    '(PYEVNW:) no more space in PYJETS for pileup events')
          IF(MSTU(21).GE.1) GOTO 310
        ENDIF
        MINT(82)=IPILE
 
C...Generate variables of hard scattering.
        MINT(51)=0
        MSTI(52)=0
        LOOPHS  =0
  100   CONTINUE
        LOOPHS  = LOOPHS + 1
        IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
        IF(LOOPHS.GE.10) THEN
          CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
     &        //'multiple interactions. Returning.')
          MINT(51)=1
          RETURN
        ENDIF
        MINT(31)=0
        MINT(39)=0
        MINT(36)=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 290
 
C...Loopback point if PYPREP fails, especially for junction topologies.
        NPREP=0
        MNT31S=MINT(31)
  110   NPREP=NPREP+1
        MINT(31)=MNT31S
 
        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)
  120     MINT(31)=MINT31
          MINT(51)=0
          CALL PYSCAT
          IF(MINT(51).EQ.1) GOTO 100
          NPARTD=N
          NFIN=N
 
C...Intertwined initial state showers and multiple interactions.
C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
          MSTP61=MSTP(61)
          IF (MINT(47).LT.2) MSTP(61)=0
          MSTP81=MSTP(81)
          IF (MINT(50).EQ.0) MSTP(81)=0
          IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
     &    MINT(111).NE.12) THEN
C...Absolute max pT2 scale for evolution: phase space limit.
            PT2MXS=0.25D0*VINT(2)
C...Check if more constrained by ISR and MI max scales:
            PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
C...Loopback point in case of failure in evolution.
            LOOP=0
  130       LOOP=LOOP+1
            MINT(51)=0
            IF(LOOP.GT.100) THEN
              CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
     &             //'multiple interactions. Trying new point.')
              MINT(51)=1
              RETURN
            ENDIF
 
C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
C...once per event. (E.g. compute constants and save variables to be
C...restored later in case of failure.)
            IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
 
C...Initialize interleaved MI/ISR/JI evolution.
C...PT2MAX: absolute upper limit for evolution - Initialization may
C...        return a PT2MAX which is lower than this.
C...PT2MIN: absolute lower limit for evolution - Initialization may
C...        return a PT2MIN which is larger than this (e.g. Lambda_QCD).
            PT2MAX=PT2MXS
            PT2MIN=0D0
            CALL PYEVOL(0,PT2MAX,PT2MIN)
C...If failed to initialize evolution, generate a new hard process
            IF (MINT(51).EQ.1) GOTO 100
 
C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
C...In principle factorized, so can be stopped and restarted.
C...Example: stop/start at pT=10 GeV. (Commented out for now.)
C            PT2MED=MAX(10D0**2,PT2MIN)
C            CALL PYEVOL(1,PT2MAX,PT2MED)
C            IF (MINT(51).EQ.1) GOTO 160
C            PT2MAX=PT2MED
            CALL PYEVOL(1,PT2MAX,PT2MIN)
C...If fatal error (e.g., massive hard-process initiator, but no available 
C...phase space for creation), generate a new hard process
            IF (MINT(51).EQ.2) GOTO 100
C...If smaller error, just try running evolution again
            IF (MINT(51).EQ.1) GOTO 130
 
C...Finalize interleaved MI/ISR/JI evolution.
            CALL PYEVOL(2,PT2MAX,PT2MIN)
            IF (MINT(51).EQ.1) GOTO 130
 
          ENDIF
          MSTP(61)=MSTP61
          MSTP(81)=MSTP81
          IF(MINT(51).EQ.1) GOTO 100
C...(MINT(52) is actually obsolete in this routine. Set anyway
C...to ensure PYDOCU stable.)
          MINT(52)=N
          MINT(53)=N
 
C...Beam remnants - new scheme.
  140     IF(MINT(50).EQ.1) THEN
            IF (ISUB.EQ.95) MINT(31)=1
 
C...Beam remnant flavour and colour assignments - new scheme.
            CALL PYMIHK
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &           GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
 
C...Primordial kT and beam remnant momentum sharing - new scheme.
            CALL PYMIRM
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
            IF (ISUB.EQ.95) MINT(31)=0
          ELSEIF(MINT(111).NE.12) THEN
C...Hadron remnants and primordial kT - old model.
C...Happens e.g. for direct photon on one side.
            IPU1=IMI(1,1,1)
            IPU2=IMI(2,1,1)
            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
C...PYREMN does not set colour tags for BRs, so needs to be done now.
            DO 160 I=MINT(53)+1,N
              DO 150 KCS=4,5
                IDA=MOD(K(I,KCS),MSTU(5))
                IF (IDA.NE.0) THEN
                  MCT(I,KCS-3)=MCT(IDA,6-KCS)
                ELSE
                  MCT(I,KCS-3)=0
                ENDIF
  150         CONTINUE
  160       CONTINUE
C...Instruct PYPREP to use colour tags
            MINT(33)=1

            DO 360 MQGST=1,2
              DO 350 I=MINT(84)+1,N
  
C...Look for coloured string endpoint, or (later) leftover gluon.
                IF (K(I,1).NE.3) GOTO 350
                KC=PYCOMP(K(I,2))
                IF(KC.EQ.0) GOTO 350
                KQ=KCHG(KC,2)
                IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
  
C...  Pick up loose string end with no previous tag.
                KCS=4
                IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
                IF(MCT(I,KCS-3).NE.0) GOTO 350
                  
                CALL PYCTTR(I,KCS,I)
                IF(MINT(51).NE.0) RETURN
  
 350          CONTINUE
 360        CONTINUE
C...Now delete any colour processing information if set (since partons
C...otherwise not FS showered!)
            DO 170 I=MINT(84)+1,N
              IF (I.LE.N) THEN
                K(I,4)=MOD(K(I,4),MSTU(5)**2)
                K(I,5)=MOD(K(I,5),MSTU(5)**2)
              ENDIF
  170       CONTINUE
          ENDIF
 
C...Showering of final state partons (optional).
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
     &    THEN
            QMAX=VINT(55)
            IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
            CALL PYPTFS(1,QMAX,0D0,PTGEN)
C...External processes: handle successive showers.
          ELSEIF(ISET(ISUB).EQ.11) THEN
            CALL PYADSH(NFIN)
          ENDIF
          PARJ(81)=ALAMSV

C...Allow possibility for user to abort event generation.
          IVETO=0
          IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
          IF(IVETO.EQ.1) GOTO 100

 
C...Decay of final state resonances.
          MINT(32)=0
          IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
            CALL PYRESD(0)
            IF(MINT(51).NE.0) GOTO 100
          ENDIF
 
          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.
        MINT(54)=N
        IF(MSTP(111).GE.1) THEN
          NFIX=N
          DO 180 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
              KCA=PYCOMP(K(I,2))
              IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
                CALL PYRESD(I)
                IF(MINT(51).EQ.1) GOTO 100
              ENDIF
            ENDIF
  180     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 190 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)
  190     CONTINUE
          NRECAL=N
        ENDIF
 
C...Colour reconnection before string formation
        CALL PYFSCR(MINT(84)+1)
 
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(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
          MSTU(24)=0
          GOTO 100
        ENDIF
        IF(MINT(51).EQ.1) GOTO 110
        IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
          DO 220 I=MINT(84)+1,N
            IF(K(I,2).EQ.94) THEN
              DO 210 I1=I+1,MIN(N,I+10)
                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 200 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
  200               CONTINUE
                    IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
                  ENDIF
                ENDIF
 210          CONTINUE
CC...Also collapse particles decaying to themselves (if same KS)
            ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
     &            .AND.K(I,4).LT.N) THEN
              IDA=K(I,4)
              IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
                K(I,1)=0
              ENDIF
            ENDIF
  220     CONTINUE
          CALL PYEDIT(12)
          CALL PYEDIT(14)
          IF(MSTP(125).EQ.0) CALL PYEDIT(15)
          IF(MSTP(125).EQ.0) MINT(4)=0
          DO 240 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 230 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
  230         CONTINUE
            ENDIF
  240     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 250 J=1,4
            VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
     &      SIN(PARU(2)*PYR(0))
  250     CONTINUE
          DO 270 I=MINT(83)+1,N
            DO 260 J=1,4
              V(I,J)=V(I,J)+VTX(J)
  260       CONTINUE
  270     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 280 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)
  280     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.
  290   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)
  300 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.
  310 CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)
 
C...Error messages
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
      PARAMETER (EPS=1D-3)
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(8000,2),BRAT(8000),KFDP(8000,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, CHTMP*16
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
C...Local arrays, character variables and data.
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
      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
      CHARACTER*24 CHD0, CHDC(10)
      CHARACTER*6 DNAME(3)
      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''       '/
      DATA DNAME /'q     ','lepton','nu    '/
 
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) MSTU(23),MSTU(30),MSTU(27),
     &  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
              BRPRI=0D0
              IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
              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),BRPRI,
     &          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),BRPRI,
     &          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)
 
      ELSEIF(MSTAT.EQ.7) THEN
      WRITE (MSTU(11),8000)
      NMODES(0)=0
      NMODES(10)=0
      NMODES(9)=0
      DO 290 ILR=1,2
        DO 280 KFSM=1,16
          KFSUSY=ILR*KSUSY1+KFSM
          NRVDC=0
C...SDOWN DECAYS
          IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
            NRVDC=3
            DO 190 I=1,NRVDC
              PBRAT(I)=0D0
              NMODES(I)=0
  190       CONTINUE
            CALL PYNAME(KFSUSY,CHTMP)
            CHD0=CHTMP//' '
            CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
            CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
            CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
            KC=PYCOMP(KFSUSY)
            DO 200 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              ID1=IABS(KFDP(IDC,1))
              ID2=IABS(KFDP(IDC,2))
              IF (KFDP(IDC,3).EQ.0) THEN
                IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
     &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  PBRAT(1)=PBRAT(1)+BRAT(IDC)
                  NMODES(1)=NMODES(1)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &                 .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
                  PBRAT(2)=PBRAT(2)+BRAT(IDC)
                  NMODES(2)=NMODES(2)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
     &                 .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  PBRAT(3)=PBRAT(3)+BRAT(IDC)
                  NMODES(3)=NMODES(3)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
              ENDIF
  200       CONTINUE
          ENDIF
C...SUP DECAYS
          IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
            NRVDC=2
            DO 210 I=1,NRVDC
              NMODES(I)=0
              PBRAT(I)=0D0
  210       CONTINUE
            CALL PYNAME(KFSUSY,CHTMP)
            CHD0=CHTMP//' '
            CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
            CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
            KC=PYCOMP(KFSUSY)
            DO 220 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              ID1=IABS(KFDP(IDC,1))
              ID2=IABS(KFDP(IDC,2))
              IF (KFDP(IDC,3).EQ.0) THEN
                IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
     &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  PBRAT(1)=PBRAT(1)+BRAT(IDC)
                  NMODES(1)=NMODES(1)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
     &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  PBRAT(2)=PBRAT(2)+BRAT(IDC)
                  NMODES(2)=NMODES(2)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
              ENDIF
  220       CONTINUE
          ENDIF
C...SLEPTON DECAYS
          IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
            NRVDC=2
            DO 230 I=1,NRVDC
              PBRAT(I)=0D0
              NMODES(I)=0
  230       CONTINUE
            CALL PYNAME(KFSUSY,CHTMP)
            CHD0=CHTMP//' '
            CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
            CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
            KC=PYCOMP(KFSUSY)
            DO 240 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              ID1=IABS(KFDP(IDC,1))
              ID2=IABS(KFDP(IDC,2))
              IF (KFDP(IDC,3).EQ.0) THEN
                IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
     &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
                  PBRAT(1)=PBRAT(1)+BRAT(IDC)
                  NMODES(1)=NMODES(1)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
                IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
     &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  PBRAT(2)=PBRAT(2)+BRAT(IDC)
                  NMODES(2)=NMODES(2)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
              ENDIF
  240       CONTINUE
          ENDIF
C...SNEUTRINO DECAYS
          IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
     &         THEN
            NRVDC=2
            DO 250 I=1,NRVDC
              PBRAT(I)=0D0
              NMODES(I)=0
  250       CONTINUE
            CALL PYNAME(KFSUSY,CHTMP)
            CHD0=CHTMP//' '
            CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
            CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
            KC=PYCOMP(KFSUSY)
            DO 260 J=1,MDCY(KC,3)
              IDC=J+MDCY(KC,2)-1
              ID1=IABS(KFDP(IDC,1))
              ID2=IABS(KFDP(IDC,2))
              IF (KFDP(IDC,3).EQ.0) THEN
                IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
     &               .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
                  PBRAT(1)=PBRAT(1)+BRAT(IDC)
                  NMODES(1)=NMODES(1)+1
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
                IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
     &               .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
                  NMODES(2)=NMODES(2)+1
                  PBRAT(2)=PBRAT(2)+BRAT(IDC)
                  IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
                  IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
                ENDIF
              ENDIF
  260       CONTINUE
          ENDIF
          IF (NRVDC.NE.0) THEN
            DO 270 I=1,NRVDC
              WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
              NMODES(0)=NMODES(0)+NMODES(I)
  270       CONTINUE
          ENDIF
  280   CONTINUE
  290 CONTINUE
      DO 370 KFSM=21,37
        KFSUSY=KSUSY1+KFSM
        NRVDC=0
C...NEUTRALINO DECAYS
        IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
          NRVDC=4
          DO 300 I=1,NRVDC
            PBRAT(I)=0D0
            NMODES(I)=0
  300     CONTINUE
          CALL PYNAME(KFSUSY,CHTMP)
          CHD0=CHTMP//' '
          CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
          CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          KC=PYCOMP(KFSUSY)
          DO 310 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            ID1=IABS(KFDP(IDC,1))
            ID2=IABS(KFDP(IDC,2))
            ID3=IABS(KFDP(IDC,3))
            IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
     &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
     &           .ID3.EQ.13.OR.ID3.EQ.15)) THEN
              PBRAT(1)=PBRAT(1)+BRAT(IDC)
              NMODES(1)=NMODES(1)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
     &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(2)=PBRAT(2)+BRAT(IDC)
              NMODES(2)=NMODES(2)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
     &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(3)=PBRAT(3)+BRAT(IDC)
              NMODES(3)=NMODES(3)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
     &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(4)=PBRAT(4)+BRAT(IDC)
              NMODES(4)=NMODES(4)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ENDIF
  310     CONTINUE
        ENDIF
C...CHARGINO DECAYS
        IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
          NRVDC=5
          DO 320 I=1,NRVDC
            PBRAT(I)=0D0
            NMODES(I)=0
  320     CONTINUE
          CALL PYNAME(KFSUSY,CHTMP)
          CHD0=CHTMP//' '
          CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
          CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
          CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          KC=PYCOMP(KFSUSY)
          DO 330 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            ID1=IABS(KFDP(IDC,1))
            ID2=IABS(KFDP(IDC,2))
            ID3=IABS(KFDP(IDC,3))
            IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
     &           .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
     &           .ID3.EQ.14.OR.ID3.EQ.16)) THEN
              PBRAT(1)=PBRAT(1)+BRAT(IDC)
              NMODES(1)=NMODES(1)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
     &             .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
     &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
              PBRAT(1)=PBRAT(1)+BRAT(IDC)
              NMODES(1)=NMODES(1)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &             .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
     &             .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
              PBRAT(2)=PBRAT(2)+BRAT(IDC)
              NMODES(2)=NMODES(2)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
     &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
              PBRAT(3)=PBRAT(3)+BRAT(IDC)
              NMODES(3)=NMODES(3)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
     &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
     &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(3)=PBRAT(3)+BRAT(IDC)
              NMODES(3)=NMODES(3)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
     &             .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
              PBRAT(4)=PBRAT(4)+BRAT(IDC)
              NMODES(4)=NMODES(4)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
     &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(4)=PBRAT(4)+BRAT(IDC)
              NMODES(4)=NMODES(4)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
     &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
     &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(5)=PBRAT(5)+BRAT(IDC)
              NMODES(5)=NMODES(5)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
     &             .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(5)=PBRAT(5)+BRAT(IDC)
              NMODES(5)=NMODES(5)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ENDIF
  330     CONTINUE
        ENDIF
C...GLUINO DECAYS
        IF (KFSM.EQ.21) THEN
          NRVDC=3
          DO 340 I=1,NRVDC
            PBRAT(I)=0D0
            NMODES(I)=0
  340     CONTINUE
          CALL PYNAME(KFSUSY,CHTMP)
          CHD0=CHTMP//' '
          CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
          KC=PYCOMP(KFSUSY)
          DO 350 J=1,MDCY(KC,3)
            IDC=J+MDCY(KC,2)-1
            ID1=IABS(KFDP(IDC,1))
            ID2=IABS(KFDP(IDC,2))
            ID3=IABS(KFDP(IDC,3))
            IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
     &           .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
     &           .ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(1)=PBRAT(1)+BRAT(IDC)
              NMODES(1)=NMODES(1)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
     &             .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
     &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(2)=PBRAT(2)+BRAT(IDC)
              NMODES(2)=NMODES(2)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
     &             .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
     &             .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
              PBRAT(3)=PBRAT(3)+BRAT(IDC)
              NMODES(3)=NMODES(3)+1
              IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
              IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
            ENDIF
  350     CONTINUE
        ENDIF
 
        IF (NRVDC.NE.0) THEN
          DO 360 I=1,NRVDC
            WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
            NMODES(0)=NMODES(0)+NMODES(I)
  360     CONTINUE
        ENDIF
  370 CONTINUE
      WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
 
      IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
        WRITE (MSTU(11),8500)
        DO 400 IRV=1,3
          DO 390 JRV=1,3
            DO 380 KRV=1,3
              WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
     &             ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
  380       CONTINUE
  390     CONTINUE
  400   CONTINUE
        WRITE (MSTU(11),8600)
      ENDIF
      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,'********* Total number of errors, excluding junctions =',
     &1X,I8,' *************'/
     &1X,'********* Total number of errors, including junctions =',
     &1X,I8,' *************'/
     &1X,'********* Total number of warnings =                   ',
     &1X,I8,' *************'/
     &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('='))
 8000 FORMAT(1X/ 1X/
     &     17X,'Sums over R-Violating branching ratios',1X/ 1X
     &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
     &     ,'Mother  -->  Sum over final state flavours',4X,'I',2X
     &     ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
     &     /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
     &     ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
     &     1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
     &     ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
     &     /1X,70('='))
 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
     &     'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
 8500 FORMAT(1X/ 1X/
     &     1X,'R-Violating couplings',1X/ 1X /
     &     1X,55('=')/
     &     1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
     &     ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
     &     ,'I',15X,'I',15X,'I',15X,'I')
 8600 FORMAT(1X,55('='))
 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
     &     ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
 
      RETURN
      END
 
C*********************************************************************
 
C...PYUPEV
C...Administers the hard-process generation required for output to the
C...Les Houches event record.
 
      SUBROUTINE PYUPEV
 
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/PYCTAG/NCT,MCT(4000,2)
      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(8000,2),BRAT(8000),KFDP(8000,5)
      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/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT4/
 
C...HEPEUP for output.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/
 
C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        STOP
      ENDIF
 
C...Special flags for hard-process generation only.
      MSTP71=MSTP(71)
      MSTP(71)=0
      MST128=MSTP(128)
      MSTP(128)=1
 
C...Initial values for some counters.
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
      MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
      MINT(33)=0
 
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...Do not allow pileup events.
      MINT(82)=1
 
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((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
 
C...Decay of final state resonances.
        MINT(32)=0
        IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
     &  CALL PYRESD(0)
        IF(MINT(51).EQ.1) GOTO 100
        MINT(52)=N
 
C...Longitudinal boost of hard scattering.
        BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
        CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
 
      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.
      MINT(54)=N
      NFIX=N
      DO 120 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
          KCA=PYCOMP(K(I,2))
          IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
            CALL PYRESD(I)
            IF(MINT(51).EQ.1) GOTO 100
          ENDIF
        ENDIF
  120 CONTINUE
 
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...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
  130 CALL PYDOCU
 
C...Transform to the desired coordinate frame.
  140 CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)
 
C...Restore special flags for hard-process generation only.
      MSTP(71)=MSTP71
      MSTP(128)=MST128
 
C...Trace colour tags; convert to LHA style labels.
      NCT=100
      DO 150 I=MINT(84)+1,N
        MCT(I,1)=0
        MCT(I,2)=0
  150 CONTINUE
      DO 160 I=MINT(84)+1,N
        KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
        IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
          IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
     &    THEN
            IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
            IDA=MOD(K(I,4),MSTU(5))
            IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,2).NE.0) THEN
              MCT(I,1)=MCT(IMO,2)
            ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,1).NE.0) THEN
              MCT(I,1)=MCT(IMO,1)
            ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
     &      MCT(IDA,2).NE.0) THEN
              MCT(I,1)=MCT(IDA,2)
            ELSE
              NCT=NCT+1
              MCT(I,1)=NCT
            ENDIF
          ENDIF
          IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
     &    THEN
            IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
            IDA=MOD(K(I,5),MSTU(5))
            IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,1).NE.0) THEN
              MCT(I,2)=MCT(IMO,1)
            ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
     &      MCT(IMO,2).NE.0) THEN
              MCT(I,2)=MCT(IMO,2)
            ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
     &      MCT(IDA,1).NE.0) THEN
              MCT(I,2)=MCT(IDA,1)
            ELSE
              NCT=NCT+1
              MCT(I,2)=NCT
            ENDIF
          ENDIF
        ENDIF
  160 CONTINUE
 
C...Put event in HEPEUP commonblock.
      NUP=N-MINT(84)
      IDPRUP=MINT(1)
      XWGTUP=1D0
      SCALUP=VINT(53)
      AQEDUP=VINT(57)
      AQCDUP=VINT(58)
      DO 180 I=1,NUP
        IDUP(I)=K(I+MINT(84),2)
        IF(I.LE.2) THEN
          ISTUP(I)=-1
          MOTHUP(1,I)=0
          MOTHUP(2,I)=0
        ELSEIF(K(I+4,3).EQ.0) THEN
          ISTUP(I)=1
          MOTHUP(1,I)=1
          MOTHUP(2,I)=2
        ELSE
          ISTUP(I)=1
          MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
          MOTHUP(2,I)=0
        ENDIF
        IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
     &  ISTUP(K(I+MINT(84),3)-MINT(84))=2
        ICOLUP(1,I)=MCT(I+MINT(84),1)
        ICOLUP(2,I)=MCT(I+MINT(84),2)
        DO 170 J=1,5
          PUP(J,I)=P(I+MINT(84),J)
  170   CONTINUE
        VTIMUP(I)=V(I,5)
        SPINUP(I)=9D0
  180 CONTINUE
 
C...Optionally write out event to disk. Minimal size for time/spin fields.
      IF(MSTP(162).GT.0) THEN
        WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
        DO 190 I=1,NUP
          IF(VTIMUP(I).EQ.0D0) THEN
            WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
     &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
     &      ' 0. 9.'
          ELSE
            WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
     &      MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
     &      VTIMUP(I),' 9.'
          ENDIF
  190   CONTINUE

C...Optional extra line with parton-density information.
        IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
     &  PARI(33),PARI(34),PARI(23),PARI(29),PARI(30) 
      ENDIF
 
C...Error messages and other print formats.
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')
 5200 FORMAT(1P,2I6,4E14.6)
 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYUPIN
C...Fills the HEPRUP commonblock with info on incoming beams and allowed
C...processes, and optionally stores that information on file.
 
      SUBROUTINE PYUPIN
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(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/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
      SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
 
C...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
C...Store info on incoming beams.
      IDBMUP(1)=K(1,2)
      IDBMUP(2)=K(2,2)
      EBMUP(1)=P(1,4)
      EBMUP(2)=P(2,4)
      PDFGUP(1)=0
      PDFGUP(2)=0
      PDFSUP(1)=MSTP(51)
      PDFSUP(2)=MSTP(51)
 
C...Event weighting strategy.
      IDWTUP=3
 
C...Info on individual processes.
      NPRUP=0
      DO 100 ISUB=1,500
        IF(MSUB(ISUB).EQ.1) THEN
          NPRUP=NPRUP+1
          XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
          XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
          XMAXUP(NPRUP)=1D0
          LPRUP(NPRUP)=ISUB
        ENDIF
  100 CONTINUE
 
C...Write info to file.
      IF(MSTP(161).GT.0) THEN
        WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
     &  PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
        DO 110 IPR=1,NPRUP
          WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
     &    LPRUP(IPR)
  110   CONTINUE
      ENDIF
 
C...Formats for printout.
 5100 FORMAT(1P,2I8,2E14.6,6I6)
 5200 FORMAT(1P,3E14.6,I6)
 
      RETURN
      END


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

C...Combine the two old-style Pythia initialization and event files
C...into a single Les Houches Event File.

      SUBROUTINE PYLHEF
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...PYTHIA commonblock: only used to provide read/write units and version.
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      SAVE /PYPARS/
 
C...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
C...User process event common block.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/

C...Lines to read in assumed never longer than 200 characters. 
      PARAMETER (MAXLEN=200)
      CHARACTER*(MAXLEN) STRING

C...Format for reading lines.
      CHARACTER*6 STRFMT
      STRFMT='(A000)'
      WRITE(STRFMT(3:5),'(I3)') MAXLEN

C...Rewind initialization and event files. 
      REWIND MSTP(161)
      REWIND MSTP(162)

C...Write header info.
      WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
      WRITE(MSTP(163),'(A)') '<!--'
      WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
     &MSTP(181),'.',MSTP(182)
      WRITE(MSTP(163),'(A)') '-->'       

C...Read first line of initialization info and get number of processes.
      READ(MSTP(161),'(A)',END=400,ERR=400) STRING                  
      READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
     &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP

C...Copy initialization lines, omitting trailing blanks. 
C...Embed in <init> ... </init> block.
      WRITE(MSTP(163),'(A)') '<init>' 
      DO 140 IPR=0,NPRUP
        IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
        LEN=MAXLEN+1  
  120   LEN=LEN-1
        IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
        WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
  140 CONTINUE
      WRITE(MSTP(163),'(A)') '</init>' 

C...Begin event loop. Read first line of event info or already done.
      READ(MSTP(162),'(A)',END=320,ERR=400) STRING    
  200 CONTINUE

C...Look at first line to know number of particles in event.
      READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP

C...Begin an <event> block. Copy event lines, omitting trailing blanks. 
      WRITE(MSTP(163),'(A)') '<event>' 
      DO 240 I=0,NUP
        IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
        LEN=MAXLEN+1  
  220   LEN=LEN-1
        IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
        WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
  240 CONTINUE
              
C...Copy trailing comment lines - with a # in the first column - as is.
  260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING    
      IF(STRING(1:1).EQ.'#') THEN
        LEN=MAXLEN+1  
  280   LEN=LEN-1
        IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
        WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
        GOTO 260
      ENDIF

C..End the <event> block. Loop back to look for next event.
      WRITE(MSTP(163),'(A)') '</event>' 
      GOTO 200

C...Successfully reached end of event loop: write closing tag
C...and remove temporary intermediate files (unless asked not to).
  300 WRITE(MSTP(163),'(A)') '</event>' 
  320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>' 
      IF(MSTP(164).EQ.1) RETURN
      CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
      CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
      RETURN

C...Error exit.
  400 WRITE(*,*) ' PYLHEF file joining failed!'

      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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:400),WDTE(0:400,0:5),WDTPM(0:400),
     &WDTEM(0:400,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)
          CALL PYSTOP(101)
        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
          WDTP0I=0D0
          IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
          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))*WDTP0I**2
          WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
          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
          WDTP0I=0D0
          IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(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))*WDTP0I**2
          WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
          WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
          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))*WDTP0I**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))*WDTP0I**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))
          IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) 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(42,2),1)
      KFLQL=KFDP(MDCY(42,2),2)
      KCHG(42,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(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
     &CHAF(IABS(KFLQL),1)(1:LL)//' '
      CHAF(42,2)=CHAF(42,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...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
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(39)*12,CHINIT*76,CHNAME*16
      DIMENSION LEN(3),KCDE(39),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+  ',
     &'k+          ','k-          ','ks0         ','kl0         '/
      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,110,990,6*22,321,-321,310,130/
 
C...Store initial energy. Default frame.
      VINT(290)=WIN
      MINT(111)=0
 
C...Special user process initialization; convert to normal input.
      IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
        MINT(111)=11
        IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
        CALL PYNAME(IDBMUP(1),CHNAME)
        CHBEAM=CHNAME(1:12)
        CALL PYNAME(IDBMUP(2),CHNAME)
        CHTARG=CHNAME(1:12)
      ENDIF
 
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,39
          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) CALL PYSTOP(7)
 
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:1).EQ.'3') 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:1).EQ.'4') 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:1).EQ.'5') 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...Frame defined by HEPRUP common block.
      ELSEIF(MINT(111).GE.11) THEN
        S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
     &  SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**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),6000) EBMUP(1),EBMUP(2)
          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))
        CALL PYSTOP(7)
      ENDIF
      IF(S.LT.PARP(2)**2) THEN
        WRITE(MSTU(11),5900) SQRT(S)
        CALL PYSTOP(7)
      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!')
 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
     &'GeV beam energies',13X,'I')
 
      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...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
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
 
C...Set up kinematics for events with external user processes.
      ELSEIF(MINT(111).GE.11) 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,1)=0D0
        P(1,2)=0D0
        P(2,1)=0D0
        P(2,2)=0D0
        P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
        P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
        P(1,4)=EBMUP(1)
        P(2,4)=EBMUP(2)
        VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
        CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
        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...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
C...Commonblocks and character variables.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,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/PYINT6/PROC(0:500)
      CHARACTER PROC*28
      SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
     &/PYINT6/
      CHARACTER CHIPR*10
 
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)).GT.100.OR.
     &  IABS(MINT(12)).GT.100)) 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
        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.AND.MINT(111).NE.12) 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 160 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))
  160     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 170 ISUB=131,136
            MSUB(ISUB)=1
  170     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 180 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  180   CONTINUE
        MDME(MDCY(21,2)+MSEL-1,1)=1
        MSUB(85)=1
        DO 190 J=1,MIN(12,MDCY(22,3))
          MDME(MDCY(22,2)+J-1,1)=0
  190   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 200 J=1,MIN(8,MDCY(21,3))
          MDME(MDCY(21,2)+J-1,1)=0
  200   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 210 I=201,301
            IF(ISET(I).GE.0) MSUB(I)=1
  210     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
C...Lepton-lepton processes: QED production of squarks.
          DO 220 I=201,214
            MSUB(I)=1
  220     CONTINUE
          MSUB(210)=0
          MSUB(211)=0
          MSUB(212)=0
          DO 230 I=216,228
            MSUB(I)=1
  230     CONTINUE
          DO 240 I=261,263
            MSUB(I)=1
  240     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 250 I=271,296
            MSUB(I)=1
  250     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 260 I=201,214
          MSUB(I)=1
  260   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 270 I=237,242
            MSUB(I)=1
  270     CONTINUE
          DO 280 I=246,254
            MSUB(I)=1
  280     CONTINUE
          MSUB(256)=1
        ENDIF
 
      ELSEIF(MSEL.EQ.44) THEN
C...Neutralino/Chargino pair production.
        IF(MINT(43).EQ.4) THEN
          DO 290 I=216,236
            MSUB(I)=1
  290     CONTINUE
        ELSEIF(MINT(43).EQ.1) THEN
          DO 300 I=216,228
            MSUB(I)=1
  300     CONTINUE
        ENDIF
 
      ELSEIF(MSEL.EQ.45) THEN
C...Sbottom production.
        MSUB(287)=1
        MSUB(288)=1
        IF(MINT(43).EQ.4) THEN
          DO 310 I=281,296
            MSUB(I)=1
  310     CONTINUE
        ENDIF
 
      ELSEIF(MSEL.EQ.50) THEN
C...Pair production of technipions and gauge bosons.
        DO 320 I=361,368
          MSUB(I)=1
  320   CONTINUE
        IF(MINT(43).EQ.4) THEN
          DO 330 I=370,377
            MSUB(I)=1
  330     CONTINUE
        ENDIF
 
      ELSEIF(MSEL.EQ.51) THEN
C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
        DO 340 I=381,386
          MSUB(I)=1
  340   CONTINUE
 
      ELSEIF(MSEL.EQ.61) THEN
C...Charmonium production in colour octet model, with recoiling parton.
        DO 342 I=421,439
          MSUB(I)=1
 342   CONTINUE
 
      ELSEIF(MSEL.EQ.62) THEN
C...Bottomonium production in colour octet model, with recoiling parton.
        DO 344 I=461,479
          MSUB(I)=1
 344   CONTINUE
 
      ELSEIF(MSEL.EQ.63) THEN
C...Charmonium and bottomonium production in colour octet model.
        DO 346 I=421,439
          MSUB(I)=1
          MSUB(I+40)=1
 346   CONTINUE
      ENDIF
 
C...Find heaviest new quark flavour allowed in processes 81-84.
      KFLQM=1
      DO 350 I=1,MIN(8,MDCY(21,3))
        IDC=I+MDCY(21,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 350
        KFLQM=I
  350 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 360 I=1,MIN(12,MDCY(22,3))
        IDC=I+MDCY(22,2)-1
        IF(MDME(IDC,1).LE.0) GOTO 360
        KFLFM=KFDP(IDC,1)
  360 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
 
C...Import relevant information on external user processes.
      IF(MINT(111).GE.11) THEN
        IPYPR=0
        DO 390 IUP=1,NPRUP
C...Find next empty PYTHIA process number slot and enable it.
  370     IPYPR=IPYPR+1
          IF(IPYPR.GT.500) CALL PYERRM(26,
     &    '(PYINPR.) no more empty slots for user processes')
          IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
          IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
          ISET(IPYPR)=11
C...Overwrite KFPR with references back to process number and ID.
          KFPR(IPYPR,1)=IUP
          KFPR(IPYPR,2)=LPRUP(IUP)
C...Process title.
          WRITE(CHIPR,'(I10)') LPRUP(IUP)
          ICHIN=1
          DO 380 ICH=1,9
            IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
  380     CONTINUE
          PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
C...Switch on process.
          MSUB(IPYPR)=1
  390   CONTINUE
      ENDIF
 
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
 
C...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/
 
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(8000,2),BRAT(8000),KFDP(8000,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)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYTCCO/COEFX(194:380,2)
      COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
     &/PYTCSM/,/TCPARA/
C...Local arrays, character variables and data.
      LOGICAL IOK
      CHARACTER CVAR(4)*4
      DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
     &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
     &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
     &IQ(9),IP(9)
      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
      ITECH=0
      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
C...User process intialization: cross section model dependent.
          IF(IABS(IDWTUP).EQ.1) THEN
            IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
     &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
            XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
          ELSE
            IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
     &      XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
     &      PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
            IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
     &      PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
            XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
          ENDIF
          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.MOD(MSTP(81),10).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
        ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) 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=89
            PMAS(89,1)=PARP(45)
            PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
          ENDIF
        ENDIF
        CKMX=CKIN(2)
        IF(CKMX.LE.0D0) CKMX=VINT(1)
        KCR1=PYCOMP(KFR1)
        IF(KFR1.NE.0) THEN
          IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
     &    CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
        ENDIF
        IF(KFR1.NE.0) THEN
          TAUR1=PMAS(KCR1,1)**2/VINT(2)
          GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
          MINT(72)=1
          MINT(73)=KFR1
          VINT(73)=TAUR1
          VINT(74)=GAMR1
        ENDIF
        KFR2=0
        KFR3=0
        IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
     $  (ISUB.GE.361.AND.ISUB.LE.380))
     $  THEN
          KFR2=23
          IF(ISUB.EQ.141) THEN
            KCR2=PYCOMP(KFR2)
            IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
     &       CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
              KFR2=0
            ELSE
              TAUR2=PMAS(KCR2,1)**2/VINT(2)            
              GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
              MINT(72)=2
              MINT(74)=KFR2
              VINT(75)=TAUR2
              VINT(76)=GAMR2
            ENDIF
          ELSEIF(ITECH.EQ.0) THEN
            ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
            ITECH=1
            KFR1=KTECHN+113              
            KCR1=PYCOMP(KFR1)
            KFR2=KTECHN+223
            KCR2=PYCOMP(KFR2)
            KFR3=KTECHN+115
            KCR3=PYCOMP(KFR3)
            IRES=0
C...Order the resonances
            IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
              KCT=KCR3
              KCR3=KCR2
              KCR2=KCT
            ENDIF
            IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
              KCT=KCR3
              KCR3=KCR1
              KCR1=KCT
            ENDIF
            IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
              KCT=KCR2
              KCR2=KCR1
              KCR1=KCT
            ENDIF
            DO 101 I=1,3
              IF(I.EQ.1) THEN
                SHN0=PMAS(KCR1,1)**2
              ELSEIF(I.EQ.2) THEN
                IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
                SHN0=PMAS(KCR2,1)**2
              ELSEIF(I.EQ.3) THEN
                IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
                SHN0=PMAS(KCR3,1)**2
              ENDIF
              AEM=PYALEM(SHN0)
              FAR=SQRT(AEM/ALPRHT)              
              SHN=SHN0*(1D0-FAR)
              CALL PYTECM(SHN,S1,WIDO,1)
              RES=SHN-S1
              SHN=S1*.99D0
              SHSTEP=2D0
 102          SHN=SHN+SHSTEP
              CALL PYTECM(SHN,S1,WIDO,1)
              IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
                IOK=.FALSE.
                IF(IRES.GT.0) THEN
                  IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
                ELSEIF(IRES.EQ.0) THEN
                  IOK=.TRUE.
                ENDIF
                IF(IOK) THEN
                  IRES=IRES+1
                  XMAS(IRES)=SQRT(S1)
                  XWID(IRES)=WIDO
                ENDIF
              ENDIF
              RES=SHN-S1
              IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
 101        CONTINUE
            JRES=0
            KFR1=KTECHN+213              
            KCR1=PYCOMP(KFR1)
            KFR2=KTECHN+215
            KCR2=PYCOMP(KFR2)
            IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
              KCT=KCR2
              KCR2=KCR1
              KCR1=KCT
            ENDIF
            DO 103 I=1,2
              IF(I.EQ.1) THEN
                SHN0=PMAS(KCR1,1)**2
              ELSEIF(I.EQ.2) THEN
                IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
                SHN0=PMAS(KCR2,1)**2
              ENDIF
              AEM=PYALEM(SHN0)
              FAR=SQRT(AEM/ALPRHT)              
              SHN=SHN0*(1D0-FAR)
              CALL PYTECM(SHN,S1,WIDO,2)
              RES=SHN-S1
              SHN=S1*.99D0
              SHSTEP=2D0
 104          SHN=SHN+SHSTEP
              CALL PYTECM(SHN,S1,WIDO,2)
              IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
                IOK=.FALSE.
                IF(JRES.GT.0) THEN
                  IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
                ELSEIF(JRES.EQ.0) THEN
                  IOK=.TRUE.
                ENDIF
                IF(IOK) THEN
                  JRES=JRES+1
                  YMAS(JRES)=SQRT(S1)
                  YWID(JRES)=WIDO
                ENDIF
              ENDIF
              RES=SHN-S1
              IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
 103        CONTINUE
          ENDIF
          IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
     &     ISUB.EQ.379.OR.ISUB.EQ.380) THEN
            MINT(72)=IRES
            IF(IRES.GE.1) THEN
              VINT(73)=XMAS(1)**2/VINT(2)
              VINT(74)=XMAS(1)*XWID(1)/VINT(2)
              TAUR1=VINT(73)
              GAMR1=VINT(74)
              XM1=XMAS(1)
              XG1=XWID(1)
              KFR1=1
            ENDIF
            IF(IRES.GE.2) THEN
              VINT(75)=XMAS(2)**2/VINT(2)
              VINT(76)=XMAS(2)*XWID(2)/VINT(2)
              TAUR2=VINT(75)
              GAMR2=VINT(76)
              XM2=XMAS(2)
              XG2=XWID(2)
              KFR2=2
            ENDIF
            IF(IRES.EQ.3) THEN
              VINT(77)=XMAS(3)**2/VINT(2)
              VINT(78)=XMAS(3)*XWID(3)/VINT(2)
              TAUR3=VINT(77)
              GAMR3=VINT(78)
              XM3=XMAS(3)
              XG3=XWID(3)
              KFR3=3
            ENDIF
C...Charged current:  rho+- and a+-
          ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
            MINT(72)=IRES
            IF(JRES.GE.1) THEN
              VINT(73)=YMAS(1)**2/VINT(2)
              VINT(74)=YMAS(1)*YWID(1)/VINT(2)
              KFR1=1
              TAUR1=VINT(73)
              GAMR1=VINT(74)
              XM1=YMAS(1)
              XG1=YWID(1)
            ENDIF
            IF(JRES.GE.2) THEN
              VINT(75)=YMAS(2)**2/VINT(2)
              VINT(76)=YMAS(2)*YWID(2)/VINT(2)
              KFR2=2
              TAUR2=VINT(73)
              GAMR2=VINT(74)
              XM2=YMAS(2)
              XG2=YWID(2)
            ENDIF
            KFR3=0
          ENDIF
          IF(ISUB.NE.141) THEN
            IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
     &       .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
            IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
     &       .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
            IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
     &       .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
            IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN

            ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
              MINT(72)=2
            ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
              MINT(72)=2
              MINT(74)=KFR3
              VINT(75)=TAUR3
              VINT(76)=GAMR3
            ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
              MINT(72)=2
              MINT(73)=KFR2
              VINT(73)=TAUR2
              VINT(74)=GAMR2
              MINT(74)=KFR3
              VINT(75)=TAUR3
              VINT(76)=GAMR3
            ELSEIF(KFR1.NE.0) THEN
              MINT(72)=1
            ELSEIF(KFR2.NE.0) THEN
              MINT(72)=1
              MINT(73)=KFR2
              VINT(73)=TAUR2
              VINT(74)=GAMR2
            ELSEIF(KFR3.NE.0) THEN
              MINT(72)=1
              MINT(73)=KFR3
              VINT(73)=TAUR3
              VINT(74)=GAMR3
            ELSE
              MINT(72)=0
            ENDIF
          ELSE
            IF(KFR2.NE.0.AND.KFR1.NE.0) THEN

            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
            ELSE
              MINT(72)=0
            ENDIF
          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)
          IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
          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(PYCOMP(9900024),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.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
     &         VINT(204)=VINT(201)
          VINT(209)=VINT(204)
          IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
        ENDIF
 
C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
        IPEAK7=0
        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) THEN
            NPTS(1)=NPTS(1)+1
            IPEAK7=1
          ENDIF
        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
        IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
     &   .AND.ISUB.LE.380)) THEN
          DO 125 J=1,2
            COEFX(ISUB,J)=0D0
 125      CONTINUE
        ENDIF
        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(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
              MTAU=7
            ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
              MTAU=MTAU+1              
            ENDIF
            RTAU=0.5D0
C...Special case when both resonances have same mass,
C...as is often the case in process 194.
c           IF(MINT(72).GE.2) THEN
c             IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
c    &        0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
c               IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
c                 RTAU=0.4D0
c               ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
c                 RTAU=0.6D0
c               ENDIF
c             ENDIF
c           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).GE.8) THEN
          ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
          ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
     &    GAMR3
        ENDIF
        IF(IPEAK7.EQ.1) 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) THEN
              IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
                IBIN=IBIN-1
              ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
                IBIN=3+2*MINT(72)
              ENDIF
            ENDIF
            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(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
                WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
     &           +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
              ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
                WTMAT(IBIN,7)=WTMAT(IBIN,7)
     &           +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
              ENDIF
              IF(MINT(72).EQ.3) THEN
                WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
     &           +(ATAU1/ATAU8)/(TAU+TAUR3)
                WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
     &           +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
              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)
              WTRSAV(IBIN)=WTREL(IBIN)
  200       CONTINUE
C...Auxiliary vectors to record order of permutations
            DO I=1,NBIN
              IP(I) = I
              IQ(I) = I
            ENDDO
            DO 230 IRED=1,NBIN-1
              MROW=IRED
              RESMAX=ABS(WTREL(MROW))
C...Find row with largest residual
              DO JBIN=IRED+1,NBIN
                IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
                  MROW=JBIN
                  RESMAX=ABS(WTREL(MROW))
                ENDIF
              ENDDO
              IF(RESMAX.LT.1D-20) THEN
                MSOLV=0
                GOTO 260
              ENDIF
              MCOL = IRED
              AMAX = ABS(WTMAT(MROW,MCOL))
C...Find column with largest entry
              DO JBIN=IRED+1,NBIN
                IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
                  MCOL = JBIN
                  AMAX = ABS(WTMAT(MROW,MCOL))
                ENDIF
              ENDDO
C...Swap rows if necessary
              IF(MROW.NE.IRED) THEN
                DO JBIN=1,NBIN
                  TMPE=WTMAT(IRED,JBIN)
                  WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
                  WTMAT(MROW,JBIN)=TMPE
                ENDDO
                TMPE=WTREL(IRED)
                WTREL(IRED)=WTREL(MROW)
                WTREL(MROW)=TMPE
                MTMP=IQ(IRED)
                IQ(IRED)=IQ(MROW)
                IQ(MROW)=MTMP
              ENDIF
C...Swap columns if necessary
              IF(MCOL.NE.IRED) THEN
                DO JBIN=1,NBIN
                  TMPE=WTMAT(JBIN,IRED)
                  WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
                  WTMAT(JBIN,MCOL)=TMPE
                ENDDO
                MTMP=IP(IRED)
                IP(IRED)=IP(MCOL)
                IP(MCOL)=MTMP
              ENDIF
C...Begin eliminating equations
              DO 220 IBIN=IRED+1,NBIN
                IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
                  MSOLV=0
                  GOTO 260
                ENDIF
C                RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
                RQTU=WTMAT(IBIN,IRED)
                RQTL=WTMAT(IRED,IRED)
C...Switch order of operations
                WTREL(IBIN)=WTREL(IBIN)-RQTU*
     $            (WTREL(IRED)/RQTL)
                DO 210 ICOE=IRED,NBIN
                   WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
     $                RQTU*(WTMAT(IRED,ICOE)/RQTL)
  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
              IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
                MSOLV=0
                GOTO 260
              ENDIF
              COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
              TEMPC(IRED)=COEFU(IRED)
  250       CONTINUE
C...Return to original order
            DO IBIN=1,NBIN
              MTMP=IP(IBIN)
              COEFU(MTMP)=TEMPC(IBIN)
            ENDDO
          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,
     &        WTRSAV(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) THEN
              IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
                ICOF=7
              ENDIF
            ENDIF
            IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
            IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
              COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
            ELSE
              COEF(ISUB,ICOF)=COEFO(IBIN)
            ENDIF
  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
C...Add extra headroom for UED
        IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
        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
        IF(MSTP(127).NE.1) THEN
          WRITE(MSTU(11),5900)
          CALL PYSTOP(1)
        ELSE
          WRITE(MSTU(11),6400)
          MSTI(53)=1
        ENDIF
      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.MOD(MSTP(81),10).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
          IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) 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,10D11.3)
 5600 FORMAT(1X,'Result for ',A4,':',9F9.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('='))
 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
     &'cross-section.'/
     &1X,'Execution will stop if you try to generate events.')
 
      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 alternatives.
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 160 I1=0,6
          DO 150 I2=0,6
            DO 140 J=0,5
              SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
  140       CONTINUE
  150     CONTINUE
  160   CONTINUE
 
C...Save various common process variables.
        DO 170 J=1,10
          INTCP(IGA,J)=MINT(40+J)
  170   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 190 ICP=1,NCP(IGA)
          I=NSUBCP(IGA,ICP)
          DO 180 J=1,3
            NGENCP(IGA,ICP,J)=NGEN(I,J)
            XSECCP(IGA,ICP,J)=XSEC(I,J)
  180     CONTINUE
  190   CONTINUE
        DO 200 J=1,3
          NGENCP(IGA,0,J)=NGEN(0,J)
          XSECCP(IGA,0,J)=XSEC(0,J)
  200   CONTINUE
 
C...Choose between allowed alternatives.
      ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
        IF(ISAVE.EQ.4) THEN
          XSUMCP=0D0
          DO 210 IG=1,MINT(121)
            XSUMCP=XSUMCP+XSECCP(IG,0,1)
  210     CONTINUE
          XSUMCP=XSUMCP*PYR(0)
          DO 220 IG=1,MINT(121)
            IGA=IG
            XSUMCP=XSUMCP-XSECCP(IG,0,1)
            IF(XSUMCP.LE.0D0) GOTO 230
  220     CONTINUE
  230     CONTINUE
        ENDIF
 
C...Restore cross-section information.
        DO 240 I=1,500
          MSUB(I)=0
  240   CONTINUE
        DO 270 ICP=1,NCP(IGA)
          I=NSUBCP(IGA,ICP)
          MSUB(I)=MSUBCP(IGA,ICP)
          DO 250 J=1,20
            COEF(I,J)=COEFCP(IGA,ICP,J)
  250     CONTINUE
          DO 260 J=1,3
            NGEN(I,J)=NGENCP(IGA,ICP,J)
            XSEC(I,J)=XSECCP(IGA,ICP,J)
  260     CONTINUE
  270   CONTINUE
        DO 280 J=1,3
          NGEN(0,J)=NGENCP(IGA,0,J)
          XSEC(0,J)=XSECCP(IGA,0,J)
  280   CONTINUE
        DO 310 I1=0,6
          DO 300 I2=0,6
            DO 290 J=0,5
              SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
  290       CONTINUE
  300     CONTINUE
  310   CONTINUE
 
C...Restore various common process variables.
        DO 320 J=1,10
          MINT(40+J)=INTCP(IGA,J)
  320   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 330 I=1,500
          MSUB(I)=0
          NGEN(I,1)=0
          NGEN(I,3)=0
          XSEC(I,3)=0D0
  330   CONTINUE
        NGEN(0,1)=0
        NGEN(0,2)=0
        NGEN(0,3)=0
        XSEC(0,3)=0
        DO 350 IG=1,MINT(121)
          DO 340 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)
  340     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)
  350   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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
 
C...User process initialization and event commonblocks.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPRUP/,/HEPEUP/
 
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(8000,2),BRAT(8000),KFDP(8000,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/PYMSSM/IMSS(0:99),RMSS(0:99)
      COMMON/PYTCCO/COEFX(194:380,2)
      COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
     &/TCPARA/
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
      ISTSB=0
      LOOP=0
  100 LOOP=LOOP+1
      MINT(51)=0
      MINT(143)=1
      VINT(97)=1D0
 
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.GE.91.AND.ISUB.LE.96) THEN
      ELSEIF(MINT(82).EQ.1) 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, possibly by user process machinery.
C...(If the latter, also event will be picked here.)
        IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
          CALL UPEVNT
          CALL PYUPRE
        ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
          CALL UPEVNT
          CALL PYUPRE
          ISUB=0
  110     ISUB=ISUB+1
          IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
     &    ISUB.LT.500) GOTO 110
        ELSE
          RSUB=XSEC(0,1)*PYR(0)
          DO 120 I=1,500
            IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
            ISUB=I
            RSUB=RSUB-XSEC(I,1)
            IF(RSUB.LE.0D0) GOTO 130
  120     CONTINUE
  130     IF(ISUB.EQ.95) ISUB=96
          IF(ISUB.EQ.96) INMULT=1
          IF(ISET(ISUB).EQ.11) THEN
            IDPRUP=KFPR(ISUB,2)
            CALL UPEVNT
            CALL PYUPRE
          ENDIF
        ENDIF
 
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 (may include impact parameter).
      IF(INMULT.EQ.1) THEN
        IF(MINT(35).LE.1) CALL PYMULT(2)
        IF(MINT(35).GE.2) CALL PYMIGN(2)
      ENDIF
 
C...Loopback point for minimum bias in photon physics.
      LOOP2=0
  140 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.AND.ISUB.NE.255.AND.
     &  ISUB.NE.257) 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...Random choice of flavours for some UED processes
c...The production processes can generate a doublet pair,
c...a singlet pair, or a doublet + singlet.
      IF(ISUB.EQ.313)THEN
C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
         IF(PYR(0).LE.0.1)THEN
            KFPR(ISUB,1)=5100001
         ELSE
            KFPR(ISUB,1)=5100002
         ENDIF
         KFPR(ISUB,2)=KFPR(ISUB,1)
      ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
         IF(PYR(0).LE.0.1)THEN
            KFPR(ISUB,1)=5100001
         ELSE
            KFPR(ISUB,1)=5100002
         ENDIF
         KFPR(ISUB,2)=-KFPR(ISUB,1)
      ELSEIF(ISUB.EQ.316)THEN
C...qi + qbarj -> q*_Di + q*_Sbarj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
c Changed from private pythia6410_ued code
c            KFPR(ISUB,2)=-5010001
            KFPR(ISUB,2)=-6100002
         ELSE
            KFPR(ISUB,1)=5100002
c Changed from private pythia6410_ued code
c            KFPR(ISUB,2)=-5010002
            KFPR(ISUB,2)=-6100001
         ENDIF
      ELSEIF(ISUB.EQ.317)THEN
C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
            KFPR(ISUB,2)=-5100002
         ELSE
            KFPR(ISUB,1)=5100002
            KFPR(ISUB,2)=-5100001
         ENDIF
      ELSEIF(ISUB.EQ.318)THEN
C...qi + qj -> q*_Di + q*_Sj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
            KFPR(ISUB,2)=6100002
         ELSE
            KFPR(ISUB,1)=5100002
            KFPR(ISUB,2)=6100001
         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=89
          PMAS(89,1)=PARP(45)
          PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
        ENDIF
      ENDIF
      CKMX=CKIN(2)
      IF(CKMX.LE.0D0) CKMX=VINT(1)
      KCR1=PYCOMP(KFR1)
      IF(KFR1.NE.0) THEN
        IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
     &  CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
      ENDIF
      IF(KFR1.NE.0) THEN
        TAUR1=PMAS(KCR1,1)**2/VINT(2)
        GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
        MINT(72)=1
        MINT(73)=KFR1
        VINT(73)=TAUR1
        VINT(74)=GAMR1
      ENDIF
      KFR2=0
      KFR3=0
      IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
     $(ISUB.GE.361.AND.ISUB.LE.380))
     $THEN
        KFR2=23
        IF(ISUB.EQ.141) THEN
          KCR2=PYCOMP(KFR2)
          IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
     &     CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
            KFR2=0
          ELSE
            TAUR2=PMAS(KCR2,1)**2/VINT(2)            
            GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
            MINT(72)=2
            MINT(74)=KFR2
            VINT(75)=TAUR2
            VINT(76)=GAMR2
          ENDIF
C...3 resonances at work:   rho, omega, a
        ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
     &     .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
          MINT(72)=IRES
          IF(IRES.GE.1) THEN
            VINT(73)=XMAS(1)**2/VINT(2)
            VINT(74)=XMAS(1)*XWID(1)/VINT(2)
            TAUR1=VINT(73)
            GAMR1=VINT(74)
            KFR1=1
          ENDIF
          IF(IRES.GE.2) THEN
            VINT(75)=XMAS(2)**2/VINT(2)
            VINT(76)=XMAS(2)*XWID(2)/VINT(2)
            TAUR2=VINT(75)
            GAMR2=VINT(76)
            KFR2=2
          ENDIF
          IF(IRES.EQ.3) THEN
            VINT(77)=XMAS(3)**2/VINT(2)
            VINT(78)=XMAS(3)*XWID(3)/VINT(2)
            TAUR3=VINT(77)
            GAMR3=VINT(78)
            KFR3=3
          ENDIF
C...Charged current:  rho+- and a+-
        ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
          MINT(72)=IRES
          IF(JRES.GE.1) THEN
            VINT(73)=YMAS(1)**2/VINT(2)
            VINT(74)=YMAS(1)*YWID(1)/VINT(2)
            KFR1=1
            TAUR1=VINT(73)
            GAMR1=VINT(74)
          ENDIF
          IF(JRES.GE.2) THEN
            VINT(75)=YMAS(2)**2/VINT(2)
            VINT(76)=YMAS(2)*YWID(2)/VINT(2)
            KFR2=2
            TAUR2=VINT(73)
            GAMR2=VINT(74)
          ENDIF
          KFR3=0
        ENDIF
        IF(ISUB.NE.141) THEN
          IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN

          ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
            MINT(72)=2
          ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
            MINT(72)=2
            MINT(74)=KFR3
            VINT(75)=TAUR3
            VINT(76)=GAMR3
          ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
            MINT(72)=2
            MINT(73)=KFR2
            VINT(73)=TAUR2
            VINT(74)=GAMR2
            MINT(74)=KFR3
            VINT(75)=TAUR3
            VINT(76)=GAMR3
          ELSEIF(KFR1.NE.0) THEN
            MINT(72)=1
          ELSEIF(KFR2.NE.0) THEN
            MINT(72)=1
            MINT(73)=KFR2
            VINT(73)=TAUR2
            VINT(74)=GAMR2
          ELSEIF(KFR3.NE.0) THEN
            MINT(72)=1
            MINT(73)=KFR3
            VINT(73)=TAUR3
            VINT(74)=GAMR3
          ELSE
            MINT(72)=0
          ENDIF
        ELSE
          IF(KFR2.NE.0.AND.KFR1.NE.0) THEN

          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
          ELSE
            MINT(72)=0
          ENDIF
        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 160 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 150 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
  150         CONTINUE
            ELSEIF(KFLW.EQ.6) THEN
              PMMN(I)=PMAS(24,1)+PMAS(5,1)
            ENDIF
          ENDIF
  160   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)
        IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
        VINT(204)=PMAS(23,1)
        IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
     &   VINT(204)=PMAS(24,1) 
        IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),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.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
     &         VINT(204)=VINT(201)
        VINT(209)=VINT(204)
          IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
      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 180 I1=I1MN,I1MX
          KFV1=110*I1+3
          DO 170 I2=I2MN,I2MX
            KFV2=110*I2+3
            VRN=VRN-SIGT(I1,I2,5)
            IF(VRN.LE.0D0) GOTO 190
  170     CONTINUE
  180   CONTINUE
  190   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 210 I1=I1MN,I1MX
            KFV1=110*I1+3
            DO 200 I2=I2MN,I2MX
              KFV2=110*I2+3
              VRN=VRN-SIGT(I1,I2,JJ)
              IF(VRN.LE.0D0) GOTO 220
  200       CONTINUE
  210     CONTINUE
  220     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
  230   LOOP3=LOOP3+1
        DO 240 JT=1,2
          IF(MINT(106+JT).EQ.3) THEN
            PS=VINT(2+JT)**2
            PMM(JT)=SQRT((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
  240   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 230
          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 250 JT=1,2
          PDIF(JT)=PMM(JT)
          VINT(68+JT)=PDIF(JT)
          IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
  250   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
  260   LOOP3=LOOP3+1
        DO 270 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
  270   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 260
          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 260
        ELSEIF(ISUB.EQ.93) THEN
          FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
          IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
        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 260
        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 260
        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 260
        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 260
 
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
C...Additional check to handle techni-processes with extra resonance
C....Only modify tau treatment
        IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
     &   THEN
          IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
     &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
          IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
     &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
     &     +COEFX(ISUB,1)) MTAU=9
        ENDIF
        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
        IF(MINT(35).LE.1) CALL PYMULT(3)
        IF(MINT(35).GE.2) CALL PYMIGN(3)
        ISUB=MINT(1)
 
C...Study user-defined process: kinematics plus weight.
      ELSEIF(ISTSB.EQ.11) THEN
        IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
     &  PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
        MSTI(51)=0
        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(ISUB,1)=NGEN(ISUB,1)-1
          ENDIF
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          RETURN
        ENDIF
 
C...Extract cross section event weight.
        IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
          SIGS=1D-9*XWGTUP
        ELSE
          SIGS=1D-9*XSECUP(KFPR(ISUB,1))
        ENDIF
        IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
          VINT(97)=SIGN(1D0,XWGTUP)
        ELSE
          VINT(97)=1D-9*XWGTUP
        ENDIF
 
C...Construct 'trivial' kinematical variables needed.
        KFL1=IDUP(1)
        KFL2=IDUP(2)
        VINT(41)=PUP(4,1)/EBMUP(1)
        VINT(42)=PUP(4,2)/EBMUP(2)
        IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
          CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
     &        '(listing follows):') 
          CALL PYLIST(7)
        ENDIF
        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(55)=SCALUP
        IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
        VINT(56)=VINT(55)**2
        VINT(57)=AQEDUP
        VINT(58)=AQCDUP
 
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
        IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
     &  '(PYRAND:) unacceptable ISTUP code for incoming particles')
        DO 280 IUP=3,NUP
          IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
     &    '(PYRAND:) unacceptable ISTUP code for particles')
          IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
     &    PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
          IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
     &    PUP(2,IUP)**2)
  280   CONTINUE
        VINT(47)=SQRT(VINT(48))
      ENDIF
 
C...Choose azimuthal angle.
      VINT(24)=0D0
      IF(ISTSB.NE.11) 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 290 ICHN=1,NCHN
          SIGH(ICHN)=WTGAGA*SIGH(ICHN)
  290   CONTINUE
        SIGLPT=WTGAGA*SIGLPT
      ENDIF
 
C...Multiply cross-section by user-defined weights.
      IF(MSTP(173).EQ.1) THEN
        SIGS=PARP(173)*SIGS
        DO 300 ICHN=1,NCHN
          SIGH(ICHN)=PARP(173)*SIGH(ICHN)
  300   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
        IF(MINT(35).LE.1) CALL PYMULT(4)
        IF(MINT(35).GE.2) CALL PYMIGN(4)
      ENDIF
 
C...Ratio of actual to maximum cross section.
      IF(ISTSB.NE.11) THEN
        VIOL=SIGSWT/XSEC(ISUB,1)
        IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
      ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
        VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
      ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
        VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
      ELSE
        VIOL=1D0
      ENDIF
 
C...Check that weight not negative.
      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)
          CALL PYSTOP(2)
        ENDIF
      ELSE
        IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
          VINT(109)=VIOL
          IF(MSTP(123).LE.2) 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.
      RATND=1D0
      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)
        VIOL=VIOL/RATND
        IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
          IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
     &    (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          ISUB=0
          GOTO 100
        ENDIF
        IF(VIOL.LT.PYR(0)) THEN
          GOTO 140
        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)
          CALL PYSTOP(2)
        ENDIF
      ELSEIF(MSTP(123).EQ.1) THEN
        IF(VIOL.GT.VINT(108)) THEN
          VINT(108)=VIOL
          IF(VIOL.GT.1.0001D0) 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
          IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
          IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
     &    THEN
            XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
            IF(KFPR(ISUB,1).LE.9) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ELSEIF(KFPR(ISUB,1).LE.99) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ELSE
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ENDIF
          ENDIF
          IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
            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
            IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &      VINT(22),VINT(23),VINT(26)
            IF(ISUB.LE.9) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
            ELSEIF(ISUB.LE.99) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
            ELSE
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
            ENDIF
          ENDIF
          VINT(108)=1D0
        ENDIF
      ENDIF
 
C...Multiple interactions: choose impact parameter (if not already done).
      IF(MINT(39).EQ.0) VINT(148)=1D0
      IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
     &MSTP(82).GE.3) THEN
        IF(MINT(35).LE.1) CALL PYMULT(5)
        IF(MINT(35).GE.2) CALL PYMIGN(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 320
      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 310 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 320
  310   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.
  320 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 350 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
  330     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 330
          MINT(18+JT)=1
          VINT(154+JT)=XE
          DO 340 KFLS=-25,25
            XSFX(JT,KFLS)=XPQ(KFLS)
  340     CONTINUE
        ENDIF
  350 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)
 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
 6000 FORMAT(1X,'XMAXUP(',I3,') 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
 
C...User process event common block.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/
 
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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(8000,2),BRAT(8000),KFDP(8000,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/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
     &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
     &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
     &/PYTCSM/,/PYPUED/
C...Local arrays and saved variables
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
     &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
      INTEGER IOKFLA(6),IIFLAV
C...UED related declarations:
C...equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
      DIMENSION IUEDEQ(475),MUED(2)
      DATA (IUEDEQ(I),I=451,475)/
     & 6100001,6100002,6100003,6100004,6100005,6100006, 
     & 5100001,5100002,5100003,5100004,5100005,5100006, 
     & 6100011,6100013,6100015,                         
     & 5100012,5100011,5100014,5100013,5100016,5100015, 
     & 5100021,5100022,5100023,5100024/                 
      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
        IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
        IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
        IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
      ENDIF
 
      IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
 
C...Convert bottomonium process into equivalent charmonium ones.
      IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
 
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)+100
        I=MINT(83)+JT
        IF(I.GT.MSTU(4)) GOTO 120
        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. Save pdf value.
      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
        VINT(38+JT)=XSFX(JT,MINT(14+JT))
  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.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
     &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) 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.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
     &      .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
          IF(KFLF.GE.4) GOTO 180
        ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
     &       OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
          KFLF=4
          MINT(2)=MINT(2)-2
        ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
     &        OR.ISUB.EQ.316) THEN
          KFLF=5
          MINT(2)=MINT(2)-4
        ELSEIF(ISUB.EQ.382.AND.ITCM(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/RTCM(41)**4
          IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
        ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
          KFLF=5
          MINT(2)=1
        ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
          IF(KFLF.EQ.5) 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
        MINT(3)=0
        DO 210 IUP=3,NUP
          IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
          ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
            MINT(21+IUP)=IDUP(IUP)
          ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
     &    ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
          ELSEIF(IDUP(IUP).EQ.0) THEN
          ELSE
            MINT(3)=MINT(3)+1
            IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
          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
          IF(MINT(15).EQ.21) JS=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)=KFHIGG
          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)=KFHIGG
          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)=KFHIGG
          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(41,MINT(15)+MINT(16))
 
        ELSEIF(ISUB.EQ.145) THEN
C...q + l -> LQ (leptoquark)
          IF(IABS(MINT(16)).LE.8) JS=2
          KFRES=ISIGN(42,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_tc
          KFRES=KTECHN+331
          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(42,MINT(14+JS))
          KFLQL=KFDP(MDCY(42,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(42,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(42,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
          JS=3-JS
 
        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))
          JS=3-JS
 
        ELSEIF(ISUB.EQ.191) THEN
C...f + fbar -> rho_tc0.
          KFRES=KTECHN+113
 
        ELSEIF(ISUB.EQ.192) THEN
C...f + fbar' -> rho_tc+/-
          KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
          KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
          KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
 
        ELSEIF(ISUB.EQ.193) THEN
C...f + fbar -> omega_tc0.
          KFRES=KTECHN+223
 
        ELSEIF(ISUB.EQ.194) THEN
C...f + fbar -> f' + fbar' via mixture of s-channel
C...rho_tc and omega_tc; 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_tc+ 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_L + ~e_Rbar
          IF(MINT(15).LT.0) JS=2
          IF(MINT(2).EQ.1) THEN
            MINT(20+JS)=KFPR(ISUB,1)
            MINT(23-JS)=-KFPR(ISUB,2)
          ELSE
            MINT(20+JS)=-KFPR(ISUB,1)
            MINT(23-JS)=KFPR(ISUB,2)
          ENDIF
 
        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
          IF(MINT(15).LT.0) JS=2
          IF(MINT(2).EQ.1) THEN
            MINT(20+JS)=KFPR(ISUB,1)
            MINT(23-JS)=-KFPR(ISUB,2)
          ELSE
            MINT(20+JS)=-KFPR(ISUB,1)
            MINT(23-JS)=KFPR(ISUB,2)
          ENDIF
 
        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
          IF(MINT(15).LT.0) JS=2
          IF(MINT(2).EQ.1) THEN
            MINT(20+JS)=KFPR(ISUB,1)
            MINT(23-JS)=-KFPR(ISUB,2)
          ELSE
            MINT(20+JS)=-KFPR(ISUB,1)
            MINT(23-JS)=KFPR(ISUB,2)
          ENDIF
 
        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(MINT(15).LT.0) JS=2
C          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(MINT(15).LT.0) JS=2
C          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(MINT(15).LT.0) JS=2
C          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(MINT(15).LT.0) JS=2
C          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(MINT(15).LT.0) JS=2
C          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(MINT(15).LT.0) JS=2
C          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))
          KCH2=INT(1-KCH1)/2
          IF(MINT(2).EQ.1) THEN
            MINT(21)= ISIGN(KSUSY1+24,KCH1)
            MINT(22)= -ISIGN(KSUSY1+37,KCH1)
c            IF(KCH2.EQ.0) JS=2
          ELSE
            MINT(21)= ISIGN(KSUSY1+37,KCH1)
            MINT(22)= -ISIGN(KSUSY1+24,KCH1)
            JS=2
c            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).EQ.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).EQ.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).EQ.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).EQ.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).EQ.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).EQ.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).EQ.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).EQ.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.330) THEN
        IF(ISUB.EQ.311)THEN
C...g + g -> g* + g* (UED)
          KCC=MINT(2)+12
          KCS=(-1)**INT(1.5D0+PYR(0))
          MUED(1)=472
          MUED(2)=472
          MINT(21)=IUEDEQ(472)
          MINT(22)=IUEDEQ(472)
        ELSEIF(ISUB.EQ.312)THEN
C...q + g -> q*_D + g*, q*_S + g*
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456
          IF(MINT(15).EQ.21) JS=2
          KCC=MINT(2)+6
          IF(MINT(15).EQ.21)KCC=KCC+2
          IF(MINT(15).NE.21)THEN
            KCS=ISIGN(1,MINT(15))
            MUED(2)=472
            MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
            MINT(22)=IUEDEQ(472)
            MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
          ENDIF
          IF(MINT(16).NE.21)THEN
            KCS=ISIGN(1,MINT(16))
            MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
            MUED(1)=472
            MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
            MINT(21)=IUEDEQ(472)
          ENDIF
        ELSEIF(ISUB.EQ.313)THEN
C...q + q' -> q*_D + q*_D',q*_S+q*_S'
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456
          KCC=MINT(2)         
          IF(MINT(15).EQ.MINT(16))THEN
            MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
            MUED(2)=MINT(21)
            MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
            MINT(22)=MINT(21)
          ELSE
            MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
            MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
            MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
            MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
          ENDIF
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2        
        ELSEIF(ISUB.EQ.314)THEN
C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456
          KCS=(-1)**INT(1.5D0+PYR(0))    
          XFLAOUT=PYR(0)
          IF(XFLAOUT.LE.0.2)THEN
            MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
            MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
          ELSEIF(XFLAOUT.LE.0.4)THEN
            MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
            MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
          ELSEIF(XFLAOUT.LE.0.6)THEN
            MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
            MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
          ELSEIF(XFLAOUT.LE.0.8)THEN
            MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
            MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
          ELSE
            MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
            MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
          ENDIF
          MINT(22)=-MINT(21)
          MUED(2)=-MUED(1)
          KCC=MINT(2)+10
        ELSEIF(ISUB.EQ.315)THEN
C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456
          MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
          MUED(2)=-MINT(21)
          MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
          MINT(22)=-MINT(21)
          KCC=4
        ELSEIF(ISUB.EQ.316)THEN
C...q + qbar'    -> q*_D + q*_S_bar'
          MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
          MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
          MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
          MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
          KCC=MINT(2)+2
        ELSEIF(ISUB.EQ.317)THEN
C...q + qbar'    -> q*_D + q*_D_bar', q*_S + q*_S_bar
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456      
          MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
          MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
          MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
          MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
          KCC=MINT(2)+2
        ELSEIF(ISUB.EQ.318)THEN
C...q + q'    -> q*_D + q*_S'     
          KCC=MINT(2)         
          MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
          MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))               
          MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
          MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
        ELSEIF(ISUB.EQ.319)THEN
C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
C...The two channels have the same cross section
          KKFLMI=450
          IF(PYR(0).GT.0.5)KKFLMI=456
          XFLAOUT=PYR(0)
          IIFLAV=0
C...N.B. NFLAVOURS=IUED(3)
C   DO I=1,NFLAVOURS
          DO 433 I=1,IUED(3)
            IF(I.NE.IABS(MINT(15)))THEN
              IIFLAV=IIFLAV+1
              IOKFLA(IIFLAV)=I
            ENDIF
 433      CONTINUE
          FLASTEP=1./(IUED(3)-1)
          DO I=1,IUED(3)-1
            FLAVV=FLASTEP*I
            IF(XFLAOUT.LE.FLAVV)THEN                  
              MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
              MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
              GOTO 435
            ENDIF
          ENDDO
 435      CONTINUE
          IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
            WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
            CALL PYSTOP(5000000)
          ENDIF
          MINT(22)=-MINT(21)
          KCC=4
        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 450 JT=1,2
            I=MINT(14+JT)
            IA=IABS(I)
            IF(IA.LE.10) THEN
              RVCKM=VINT(180+I)*PYR(0)
              DO 440 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 440
                MINT(20+JT)=ISIGN(IB,I)
                RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
                IF(RVCKM.LE.0D0) GOTO 450
  440         CONTINUE
            ELSE
              IB=2*((IA+1)/2)-1+MOD(IA,2)
              MINT(20+JT)=ISIGN(IB,I)
            ENDIF
  450     CONTINUE
          KCC=22
          KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
          IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
 
        ELSEIF(ISUB.EQ.353) THEN
C...f + fbar -> Z_R0
          KFRES=KFPR(ISUB,1)
 
        ELSEIF(ISUB.EQ.354) 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(KFPR(ISUB,1),KCH1+KCH2)
 
        ENDIF
 
      ELSEIF(ISUB.LE.380) THEN
 
        IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
C...f + fbar -> charged+ charged- technicolor
          KSW=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
          MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
 
        ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
C...f + fbar -> neutral neutral technicolor
          MINT(21)=KFPR(ISUB,1)
          MINT(22)=KFPR(ISUB,2)
 
        ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
C...f + fbar' -> neutral charged technicolor
          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
          MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
          MINT(20+JS)=KFPR(ISUB,IN)
 
        ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
C...f + fbar' -> charged neutral technicolor
          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
 
      ELSEIF(ISUB.LE.400) THEN
        IF(ISUB.EQ.381) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
          KCC=MINT(2)
          IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
 
        ELSEIF(ISUB.EQ.382) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
          MINT(21)=ISIGN(KFLF,MINT(15))
          MINT(22)=-MINT(21)
          KCC=4
 
        ELSEIF(ISUB.EQ.383) THEN
C...f + fbar -> g + g; th arbitrary, TC extensions
          MINT(21)=21
          MINT(22)=21
          KCC=MINT(2)+4
 
        ELSEIF(ISUB.EQ.384) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
          IF(MINT(15).EQ.21) JS=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.385) THEN
C...g + g -> f + fbar; th arbitrary, TC extensions
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFLF,KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.386) THEN
C...g + g -> g + g; th arbitrary, TC extensions
          KCC=MINT(2)+12
          KCS=(-1)**INT(1.5D0+PYR(0))
 
        ELSEIF(ISUB.EQ.387) THEN
C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
          MINT(21)=ISIGN(MINT(55),MINT(15))
          MINT(22)=-MINT(21)
          KCC=4
 
        ELSEIF(ISUB.EQ.388) THEN
C...g + g -> Q + Qbar; th arbitrary, TC extensions
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(MINT(55),KCS)
          MINT(22)=-MINT(21)
          KCC=MINT(2)+10
 
        ELSEIF(ISUB.EQ.391) THEN
C...f + fbar -> G*.
          KFRES=KFPR(ISUB,1)
 
        ELSEIF(ISUB.EQ.392) THEN
C...g + g -> G*.
          KCC=21
          KFRES=KFPR(ISUB,1)
 
        ELSEIF(ISUB.EQ.393) THEN
C...q + qbar -> g + G*;  th arbitrary.
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(20+JS)=KFPR(ISUB,1)
          MINT(23-JS)=KFPR(ISUB,2)
          KCC=17+JS
 
        ELSEIF(ISUB.EQ.394) THEN
C...q + g -> q + G*;  th = (p(f) - p(f))**2
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=KFPR(ISUB,2)
          KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.EQ.395) THEN
C...g + g -> G* + g;  th arbitrary.
          IF(PYR(0).GT.0.5D0) JS=2
          MINT(23-JS)=KFPR(ISUB,2)
          KCC=22+JS
        ENDIF
 
      ELSEIF(ISUB.LE.420) THEN
        IF(ISUB.EQ.401) THEN
C...g + g -> t + b + H+/-
          KCS=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
          MINT(22)=ISIGN(5,-KCS)
          KCC=11+INT(0.5D0+PYR(0))
          KFRES=ISIGN(KFHIGG,-KCS)
 
        ELSEIF(ISUB.EQ.402) THEN
C...q + qbar -> t + b + H+/-
          KFL=(-1)**INT(1.5D0+PYR(0))
          MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
          MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
          KCC=4
          KFRES=ISIGN(KFHIGG,-KFL*KCS)
        ENDIF
 
C...QUARKONIA+++
C...Additional code by Stefan Wolf
      ELSEIF(ISUB.LE.430) THEN
        IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
C...g + g -> QQ~[n] + g
C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...or from ISUB.EQ.68 (for ISUB.NE.421)
C...[g + g -> g + g; th arbitrary]
          MINT(21)=KFPR(ISUBSV,1)
          MINT(22)=KFPR(ISUBSV,2)
          IF(ISUB.EQ.421) THEN
             KCC=24
             KCS=(-1)**INT(1.5D0+PYR(0))
          ELSE
             KCC=MINT(2)+12
             KCS=(-1)**INT(1.5D0+PYR(0))
          ENDIF
 
        ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
C...q + g -> q + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
C...KCC copied from ISUB.EQ.28
C...[f + g -> f + g;  th = (p(f)-p(f))**2; (q + g -> q + g  only)]
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=KFPR(ISUBSV,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.GE.428.AND.ISUB.LE.430) THEN
C...q + q~ -> g + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
C...KCC copied from ISUB.EQ.13
C...[f + fbar -> g + g;  th arbitrary; (q + qbar -> g + g  only)]
          IF(PYR(0).GT.0.5) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=KFPR(ISUBSV,2)
          KCC=MINT(2)+4
        ENDIF
 
      ELSEIF(ISUB.LE.440) THEN
        IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
C...g + g -> QQ~[n] + g
C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
C...KCC and KCS copied from ISUB.EQ.86-89
C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
          MINT(21)=KFPR(ISUBSV,1)
          MINT(22)=KFPR(ISUBSV,2)
          KCC=24
          KCS=(-1)**INT(1.5D0+PYR(0))
 
        ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
C...q + g -> q + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
C...KCC and KCS copied from ISUB.EQ.112
C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
          IF(MINT(15).EQ.21) JS=2
          MINT(23-JS)=KFPR(ISUBSV,2)
          KCC=15+JS
          KCS=ISIGN(1,MINT(14+JS))
 
        ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
C...q + q~ -> g + QQ~[n]
C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
C...KCC copied from ISUB.EQ.111
C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
          IF(PYR(0).GT.0.5) JS=2
          MINT(20+JS)=21
          MINT(23-JS)=KFPR(ISUBSV,2)
          KCC=17+JS
        ENDIF
C...QUARKONIA---
 
      ENDIF
 
      IF(ISET(ISUB).EQ.11) THEN
C...Store documentation for user-defined processes
        BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
        KUPPO(1)=MINT(83)+5
        KUPPO(2)=MINT(83)+6
        I=MINT(83)+6
        DO 470 IUP=3,NUP
          KUPPO(IUP)=0
          IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
            IDOC=IDOC-1
            MINT(4)=MINT(4)-1
            GOTO 470
          ENDIF
          I=I+1
          KUPPO(IUP)=I
          K(I,1)=21
          K(I,2)=IDUP(IUP)
          IF(IDUP(IUP).EQ.0) K(I,2)=90
          K(I,3)=0
          IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
          K(I,4)=0
          K(I,5)=0
          DO 460 J=1,5
            P(I,J)=PUP(J,IUP)
  460     CONTINUE
          V(I,5)=VTIMUP(IUP)
  470   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 490 IUP=3,NUP
          N=N+1
          K(N,1)=1
          IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
          K(N,2)=IDUP(IUP)
          IF(IDUP(IUP).EQ.0) K(N,2)=90
          IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
            K(N,3)=KUPPO(IUP)
          ELSE
            K(N,3)=MINT(84)+MOTHUP(1,IUP)
          ENDIF
          K(N,4)=0
          K(N,5)=0
C...Search for daughters of intermediate colourless particles.
          IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
            DO 475 IUPDAU=IUP+1,NUP
              IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
     &        N+IUPDAU-IUP
              IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
  475       CONTINUE
          ENDIF
          DO 480 J=1,5
            P(N,J)=PUP(J,IUP)
  480     CONTINUE
          V(N,5)=VTIMUP(IUP)
  490   CONTINUE
        CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
 
C...Arrange colour flow for user-defined processes
        NLBL=0
        DO 540 IUP1=1,NUP
          I1=MINT(84)+IUP1
          IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
          IF(K(I1,1).EQ.1) K(I1,1)=3
          IF(K(I1,1).EQ.11) K(I1,1)=14
C...Find a not yet considered colour/anticolour line.
          DO 530 ISDE1=1,2
            IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
            NMAT=0
            DO 500 ILBL=1,NLBL
              IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
  500       CONTINUE
            IF(NMAT.EQ.0) THEN
              NLBL=NLBL+1
              ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
C...Find all others belonging to same line.
              I3=I1
              I4=0
              DO 520 IUP2=IUP1+1,NUP
                I2=MINT(84)+IUP2
                DO 510 ISDE2=1,2
                  IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
                    IF(ISDE2.EQ.ISDE1) THEN
                      K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
                      K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
                      I3=I2
                    ELSEIF(I4.NE.0) THEN
                      K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
                      K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
                      I4=I2
                    ELSEIF(IUP2.LE.2) THEN
                      K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
                      K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
                      I4=I2
                    ELSE
                      K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
                      K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
                      I4=I2
                    ENDIF
                  ENDIF
  510           CONTINUE
  520         CONTINUE
            ENDIF
  530     CONTINUE
  540   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 550 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))
  550     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 560 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))
  560   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 570 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
          JTA=JT
C...t and b in opposide order in event list as compared to
C...matrix element?
          IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
          IF(IABS(K(I,2)).LE.22) THEN
            P(I,5)=PYMASS(K(I,2))
          ELSE
            P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
          ENDIF
          PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
          P(I,1)=PT*COS(VINT(198+5*JTA))
          P(I,2)=PT*SIN(VINT(198+5*JTA))
  570   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)
        IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
C...t and b in opposide order in event list as compared to
C...matrix element
          P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
     &    VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
          P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
        END IF
        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 580 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))
  580   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 590 J=1,5
          P(I,J)=P(IPU5,J)
  590   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 600 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)
  600   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 620 JT=1,2
          I1=MINT(83)+8+JT
          I2=MINT(84)+4+JT
          K(I1,1)=21
          K(I1,2)=K(I2,2)
          DO 610 J=1,5
            P(I1,J)=P(I2,J)
  610     CONTINUE
  620   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 630 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))
  630   CONTINUE
 
C...Copy outgoing partons to documentation lines
        IMAX=2
        IF(IDOC.EQ.9) IMAX=3
        DO 650 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 640 J=1,5
            P(I1,J)=P(I2,J)
  640     CONTINUE
  650   CONTINUE
 
      ELSEIF(IDOC.EQ.9) THEN
C...Store colour connection indices
        DO 660 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))
  660   CONTINUE
 
C...Copy outgoing partons to documentation lines
        DO 680 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 670 J=1,5
            P(I1,J)=P(I2,J)
  670     CONTINUE
  680   CONTINUE
      ENDIF
 
C...Copy outgoing partons to list of allowed radiators.
      NPART=0
      IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
        DO 690 I=MINT(84)+3,N
          NPART=NPART+1
          IPART(NPART)=I
          PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
  690   CONTINUE
      ENDIF
 
C...Low-pT events: remove gluons used for string drawing purposes
      IF(ISUB.EQ.95) THEN
        IF(MINT(35).LE.1) THEN
          K(IPU3,1)=K(IPU3,1)+10
          K(IPU4,1)=K(IPU4,1)+10
        ENDIF
        DO 700 J=41,66
          VINTSV(J)=VINT(J)
          VINT(J)=0D0
  700   CONTINUE
        DO 720 I=MINT(83)+5,MINT(83)+8
          DO 710 J=1,5
            P(I,J)=0D0
  710     CONTINUE
  720   CONTINUE
      ENDIF
 
      RETURN
      END
 
C***********************************************************************
 
C...PYEVOL
C...Handles intertwined pT-ordered spacelike initial-state parton
C...and multiple interactions.
 
      SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
C...MODE =  0 : (Re-)initialize ISR/MI evolution.
C...Mode =  1 : Evolve event from PT2MAX to PT2MIN.
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...External
      EXTERNAL PYALPS
      DOUBLE PRECISION PYALPS
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
     &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
      COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
C...Local arrays and saved variables.
      DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
      SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
     &     ,PSAV,KSAV,VSAV
 
      SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
     &     /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
 
C----------------------------------------------------------------------
C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
C...done only once per event, while MODE=0 is repeated each time the
C...evolution needs to be restarted.
      IF (MODE.EQ.-1) THEN
        ISUBHD=MINT(1)
        NSAV=N
        NPARTS=NPART
C...Store hard scattering variables
        M15SV=MINT(15)
        M16SV=MINT(16)
        M21SV=MINT(21)
        M22SV=MINT(22)
        DO 100 J=11,80
          VINTSV(J)=VINT(J)
  100   CONTINUE
        DO 120 J=1,5
          DO 110 IS=1,4
            I=IS+MINT(84)
            PSAV(IS,J)=P(I,J)
            KSAV(IS,J)=K(I,J)
            VSAV(IS,J)=V(I,J)
  110     CONTINUE
  120   CONTINUE
 
C...Set shat for hardest scattering
        SHAT(1)=VINT(44)
        IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
     &       *VINT(2)
 
C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
        RMC=PMAS(4,1)
        RMB=PMAS(5,1)
        ALAM4=PARP(61)
        IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
        IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
        ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
 
C----------------------------------------------------------------------
C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
C...interaction initiators, with no previous evolution. Check the input
C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
C...smaller than the CM energy / 2.)
      ELSEIF (MODE.EQ.0) THEN
C...Reset counters and switches
        N=NSAV
        NPART=NPARTS
        MINT(30)=0
        MINT(31)=1
        MINT(36)=1
C...Reset hard scattering variables
        MINT(1)=ISUBHD
        DO 130 J=11,80
          VINT(J)=VINTSV(J)
  130   CONTINUE
        DO 150 J=1,5
          DO 140 IS=1,4
            I=IS+MINT(84)
            P(I,J)=PSAV(IS,J)
            K(I,J)=KSAV(IS,J)
            V(I,J)=VSAV(IS,J)
            P(MINT(83)+4+IS,J)=PSAV(IS,J)
            V(MINT(83)+4+IS,J)=VSAV(IS,J)
  140     CONTINUE
  150   CONTINUE
C...Reset statistics on activity in event.
        DO 160 J=351,359
          MINT(J)=0
          VINT(J)=0D0
  160   CONTINUE
C...Reset extra companion reweighting factor
        VINT(140)=1D0
 
C...We do not generate MI for soft process (ISUB=95), but the
C...initialization must be done regardless, for later purposes.
        MINT(36)=1
 
C...Initialize multiple interactions.
        CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
        IF(MINT(51).NE.0) RETURN
 
C...Decide whether quarks in hard scattering were valence or sea
        PT2HD=VINT(54)
        DO 170 JS=1,2
          MINT(30)=JS
          CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
          IF(MINT(51).NE.0) RETURN
  170   CONTINUE
 
C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
        VINT(18)=0D0
        PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
        IF (MSTP(70).EQ.2) THEN
C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
          VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
        ELSEIF (MSTP(70).EQ.3) THEN
C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73) 
          ALPHA0 = MAX(1D-6,PARP(73))
          Q20 = ALAM3**2/PARP(64)
          IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
          VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
        ENDIF
C...Also store PT2MIN in VINT(17).
  180   VINT(17)=PT2MIN
 
C...Set FS masses zero now.
        VINT(63)=0D0
        VINT(64)=0D0
 
C...Initialize IS showers with VINT(56) as max scale.
        PT2ISR=VINT(56)
        PT20=PT2MIN
        IF (MSTP(70).EQ.0) THEN 
          PT20=MAX(PT2MIN,PARP(62)**2)
        ELSEIF (MSTP(70).EQ.1) THEN
          PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
        ENDIF  
        CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
        IF(MINT(51).NE.0) RETURN
 
        RETURN
 
C----------------------------------------------------------------------
C...MODE= 1: Evolve event from PTMAX to PTMIN.
      ELSEIF (MODE.EQ.1) THEN
 
C...Skip if no phase space.
  190   IF (PT2MAX.LE.PT2MIN) GOTO 330
 
C...Starting pT2 max scale (to be udpated successively).
        PT2CMX=PT2MAX
 
C...Evolve two sides of the event to find which branches at highest pT.
  200   JSMX=-1
        MIMX=0
        PT2MX=0D0
 
C...Loop over current shower initiators.
        IF (MSTP(61).GE.1) THEN
          DO 230 MI=1,MINT(31)
            IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
            ISUB=96
            IF (MI.EQ.1) ISUB=ISUBHD
            MINT(1)=ISUB
            MINT(36)=MI
C...Set up shat, initiator x values, and x remaining in BR.
            VINT(44)=SHAT(MI)
            VINT(141)=XMI(1,MI)
            VINT(142)=XMI(2,MI)
            VINT(143)=1D0
            VINT(144)=1D0
            DO 210 JI=1,MINT(31)
              IF (JI.EQ.MINT(36)) GOTO 210
              VINT(143)=VINT(143)-XMI(1,JI)
              VINT(144)=VINT(144)-XMI(2,JI)
  210       CONTINUE
C...Loop over sides.
C...Generate trial branchings for this interaction. The hardest
C...branching so far is automatically updated if necessary in /PYISMX/.
            DO 220 JS=1,2
              MINT(30)=JS
              PT20=PT2MIN
              IF (MSTP(70).EQ.0) THEN 
                PT20=MAX(PT2MIN,PARP(62)**2)
              ELSEIF (MSTP(70).EQ.1) THEN
                PT20=MAX(PT2MIN,
     &              (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
              ENDIF  
              CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
              IF (MINT(51).NE.0) RETURN
  220       CONTINUE
  230     CONTINUE
        ENDIF
 
C...Generate trial additional interaction.
        MINT(36)=MINT(31)+1
  240   IF (MOD(MSTP(81),10).GE.1) THEN
          MINT(1)=96
C...Set up X remaining in BR.
          VINT(143)=1D0
          VINT(144)=1D0
          DO 250 JI=1,MINT(31)
            VINT(143)=VINT(143)-XMI(1,JI)
            VINT(144)=VINT(144)-XMI(2,JI)
  250     CONTINUE
C...Generate trial interaction
  260     CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
          IF (MINT(51).EQ.1) RETURN
        ENDIF
 
C...And the winner is:
        IF (PT2MX.LT.PT2MIN) THEN
          GOTO 330
        ELSEIF (JSMX.EQ.0) THEN
C...Accept additional interaction (may still fail).
          CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
          IF(MINT(51).NE.0) RETURN
          IF (IFAIL.EQ.0) THEN
            SHAT(MINT(36))=VINT(44)
C...Decide on flavours (valence/sea/companion).
            DO 270 JS=1,2
              MINT(30)=JS
              CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
              IF(MINT(51).NE.0) RETURN
  270       CONTINUE
          ENDIF
        ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
C...Reconstruct kinematics of acceptable ISR branching.
C...Set up shat, initiator x values, and x remaining in BR.
          MINT(30)=JSMX
          MINT(36)=MIMX
          VINT(44)=SHAT(MINT(36))
          VINT(141)=XMI(1,MINT(36))
          VINT(142)=XMI(2,MINT(36))
          VINT(143)=1D0
          VINT(144)=1D0
          DO 280 JI=1,MINT(31)
            IF (JI.EQ.MINT(36)) GOTO 280
            VINT(143)=VINT(143)-XMI(1,JI)
            VINT(144)=VINT(144)-XMI(2,JI)
  280     CONTINUE
          PT2NEW=PT2MX
          CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
          IF (MINT(51).EQ.1) RETURN
        ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
C...Bookeep joining. Cannot (yet) be constructed kinematically.
          MINT(354)=MINT(354)+1
          VINT(354)=VINT(354)+SQRT(PT2MX)
          IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
          MJOIND(JSMX-2,MJN1MX)=MJN2MX
          MJOIND(JSMX-2,MJN2MX)=MJN1MX
        ENDIF
 
C...Update PT2 iteration scale.
        PT2CMX=PT2MX
 
C...Loop back to continue evolution.
        IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
          CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
        ELSE
          IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
        ENDIF
 
C----------------------------------------------------------------------
C...MODE= 2: (Re-)store user information on hardest interaction etc.
      ELSEIF (MODE.EQ.2) THEN
 
C...Revert to "ordinary" meanings of some parameters.
  290   DO 310 JS=1,2
          MINT(12+JS)=K(IMI(JS,1,1),2)
          VINT(140+JS)=XMI(JS,1)
          IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
          VINT(142+JS)=1D0
          DO 300 MI=1,MINT(31)
            VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
  300     CONTINUE
  310   CONTINUE
 
C...Restore saved quantities for hardest interaction.
        MINT(1)=ISUBHD
        MINT(15)=M15SV
        MINT(16)=M16SV
        MINT(21)=M21SV
        MINT(22)=M22SV
        DO 320 J=11,80
          VINT(J)=VINTSV(J)
  320   CONTINUE
 
      ENDIF
 
  330 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
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
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),DPHI(2),MCESV(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)
      VINT2R=VINT(2)*VINT(143)*VINT(144)
      IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
     &MIN(VINT2R,PARP(67)*VINT(56))
      FCQ2MX=1D0
 
C...Define which processes ME corrections have been implemented for.
      MECOR=0
      IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
        IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
     &  ISUB.EQ.144) MECOR=1
        IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
        IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
      ENDIF
 
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(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
        MEEV=2
        TEMX=TCMX
        FWTE=1D0
      ENDIF
      IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
 
C...Loopback point in case of failure to reconstruct kinematics.
      NS=N
      NPARTS=NPART
      LOOP=0      
      MNT352=MINT(352)
      MNT353=MINT(353)
      VNT352=VINT(352)
      VNT353=VINT(353)
  100 LOOP=LOOP+1
      IF(LOOP.GT.100) THEN
        MINT(51)=1
        RETURN
      ENDIF
      N=NS
      NPART=NPARTS
      MINT(352)=MNT352
      MINT(353)=MNT353
      VINT(352)=VNT352
      VINT(353)=VNT353
 
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)
        IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
        ZS(JT)=1D0
        Q2S(JT)=FCQ2MX*Q2MX
        DQ2(JT)=0D0
        TEVCSV(JT)=TCMX
        ALAM(JT)=PARP(61)
        THE2(JT)=1D0
        TEVESV(JT)=TEMX
        MCESV(JT)=0
C...Calculate initial parton distribution weights.
        MINT(105)=MINT(102+JT)
        MINT(109)=MINT(106+JT)
        VINT(120)=VINT(2+JT)
        IF(XS(JT).LT.1D0-XEE) THEN
          IF(MINT(31).GE.2) MINT(30)=JT
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
          ELSE
            CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
          ENDIF
        ENDIF
        DO 110 KFL=-25,25
          XFS(JT,KFL)=XFB(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.
      JTOLD=1
  150 N=N+1
      JT=1
      IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
      IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
      IF(MORE(JT).EQ.0) JT=3-JT
      JTOLD=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/VINT2R,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(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
     &MEEV=2
      IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
        Q2B=0D0
        GOTO 260
      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
      IF(MEEV.EQ.2) TEVEB=TEVCB
      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 preweighting factor for ME-corrected processes.
      IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
 
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 or gamma emission), 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))
        EQ2=1D0/9D0
        IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
        IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
     &  (XEC*(1D0-XEC)))
        IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
          WTAPC(KFLB)=WTFF*WTAPC(KFLB)
          WTAPC(21)=WTGF*WTAPC(21)
          WTAPE(KFLB)=WTFF*WTAPE(KFLB)
        ENDIF
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.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
          WTAPE(KFLB)=WTFF*WTAPE(KFLB)
          WTAPE(22)=WTGF*WTAPE(22)
        ENDIF
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)
        IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
          DO 190 KFL=1,MSTP(58)
            WTAPC(KFL)=WTFG*WTAPC(KFL)
            WTAPC(-KFL)=WTFG*WTAPC(-KFL)
  190     CONTINUE
          WTAPC(21)=WTGG*WTAPC(21)
        ENDIF
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
        IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
          WTAPE(11)=WTFG*WTAPE(11)
          WTAPE(-11)=WTFG*WTAPE(-11)
        ENDIF
      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
  200 NTRY=NTRY+1
      IF(NTRY.GT.500) THEN
        MINT(51)=1
        RETURN
      ENDIF
      WTSUMC=0D0
      WTSUME=0D0
      XFBO=MAX(1D-10,XFB(KFLB))
      DO 210 KFL=-25,25
        WTSF(KFL)=XFB(KFL)/XFBO
        WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
        WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
  210 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
  220 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)))
      ELSEIF(MEEV.EQ.2) THEN
        TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
      ENDIF
 
C...Translate t into Q2 scale; choose between QCD and QED evolution.
  230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
      IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
      IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
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.1D0*PMAS(KFLCB,1)**2
          TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
          FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
        ENDIF
      ENDIF
      IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
     &MEEV.EQ.2) THEN
        IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
      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(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
        IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
      ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
        IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
        IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) 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 260
      ELSEIF(MCE.EQ.1) THEN
        Q2B=Q2CB
        Q2REF=FQ2C*Q2B
        IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
        IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
      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
  240 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 240
      IF(KFLA.EQ.25) THEN
        Q2B=0D0
        GOTO 260
      ENDIF
 
C...Choose z value and corrective weight.
      WTZ=0D0
C...q -> q + g or q -> q + gamma.
      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.AND.MEEV.EQ.1) 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 220
        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 220
          ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
          IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
          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 220
 
C...Select phi angle of branching at random.
      PHIBR=PARU(2)*PYR(0)
 
C...Matrix-element corrections for some processes.
      IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
        IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
          CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
          WTZ=WTZ*WTME/WTFF
        ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
          CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
          WTZ=WTZ*WTME/WTGF
        ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
          CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
          WTZ=WTZ*WTME/WTFG
        ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
          CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
          WTZ=WTZ*WTME/WTGG
        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 220
          ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
            IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
          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*VINT2R)
          IF(THE2T.GT.THE2(JT)) GOTO 220
        ENDIF
      ENDIF
 
C...Weighting with new parton distributions.
      MINT(105)=MINT(102+JT)
      MINT(109)=MINT(106+JT)
      VINT(120)=VINT(2+JT)
      IF(MINT(31).GE.2) MINT(30)=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 200
        ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
          TEVCB=0.5D0*(TEVCBS+TEVCB)
          GOTO 230
        ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
          TEVEB=0.5D0*(TEVEBS+TEVEB)
          GOTO 230
        ELSE
          XFBN=1D-10
          XFN(KFLB)=XFBN
        ENDIF
      ENDIF
      DO 250 KFL=-25,25
        XFB(KFL)=XFN(KFL)
  250 CONTINUE
      XA=XB/Z
      IF(MINT(31).GE.2) MINT(30)=JT
      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 200
      WTSFA=WTSF(KFLA)
      IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
 
C...Define two hard scatterers in their CM-frame.
  260 IF(N.EQ.NS+2) THEN
        DQ2(JT)=Q2B
        DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
        DO 280 JR=1,2
          I=NS+JR
          IF(JR.EQ.1) IPO=IPUS1
          IF(JR.EQ.2) IPO=IPUS2
          DO 270 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  270     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
          MCT(I,1)=MCT(IPO,1)
          MCT(I,2)=MCT(IPO,2)
  280   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 290 J=1,5
          K(IT,J)=0
          P(IT,J)=0D0
          V(IT,J)=0D0
  290   CONTINUE
C...f -> f + g (gamma).
        IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
          K(IT,2)=21
          IF(MCESV(JT).EQ.2.OR.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.MCESV(JT).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
C...Only do timelike shower here if using PYSHOW
          IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
            CALL PYSHOW(IT,0,SQRT(Q2TIM))
          ENDIF
          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 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)=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))
        MCT(N+1,1)=0
        MCT(N+1,2)=0
 
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
        IF(K(IT,1).EQ.1) THEN
          K(IT,4)=0
          K(IT,5)=0
        ENDIF
 
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)),DPHI(JT),
     &  0D0,0D0,0D0)
 
C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
        IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
          NPART=NPART+1
          IPART(NPART)=IT
          PTPART(NPART)=SQRT(PARP(71)*DPT2)
        ENDIF

C...Global statistics.
        MINT(352)=MINT(352)+1
        VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
        IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)

      ENDIF
 
C...Update kinematics variables.
      IS(JT)=N
      DQ2(JT)=Q2B
      IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
      DSH=DSHZ
 
C...Save quantities; loop back.
      Q2S(JT)=Q2B
      DPHI(JT)=PHIBR
      MCESV(JT)=MCE
      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 310 KFL=-25,25
          XFS(JT,KFL)=XFA(KFL)
  310   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 320 J=1,3
        ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
  320 CONTINUE
      K(N+2,1)=1
      DO 330 J=1,5
        P(N+2,J)=P(NS+1,J)
  330 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))
      IMIN=MINT(83)+5
      IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
      CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
      CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
 
C...Store user information. Reset Lambda value.
      IF(MINT(31).LE.1) THEN
        K(IPU1,3)=MINT(83)+3
        K(IPU2,3)=MINT(83)+4
      ELSE
        K(IPU1,3)=MINT(83)+1
        K(IPU2,3)=MINT(83)+2
      ENDIF
      DO 340 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)
        IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
  340 CONTINUE
      PARU(112)=ALAMS
 
      RETURN
      END

C*********************************************************************
 
C...PYPTIS
C...Generates pT-ordered spacelike initial-state parton showers and
C...trial joinings.
C...MODE=-1: Initialize ISR from scratch, starting from the hardest
C...         interaction initiators at PT2NOW.
C...MODE= 0: Generate a trial branching on interaction MINT(36), side
C...         MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
C...         Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
C...         is below PT2CUT.
C...         (Also generate test joinings if MSTP(96)=1.)
C...MODE= 1: Accept stored shower branching. Update event record etc.
C...PT2NOW : Starting (max) PT2 scale for evolution.
C...PT2CUT : Lower limit for evolution.
C...PT2    : Result of evolution. Generated PT2 for trial emission.
C...IFAIL  : Status return code. IFAIL=0 when all is well.
 
      SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
     &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
      COMMON/PYCTAG/NCT,MCT(4000,2)
      COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
      SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
     &     /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
C...Local variables
      DIMENSION ZSAV(2,240),PT2SAV(2,240),
     &     XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
     &     WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
     &     WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
      SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
     &     RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
C...For check on excessive weights.
      CHARACTER CHWT*12
 
C...Only give errors for very large weights, otherwise just warnings
      DATA WTEMAX /1.5D0/
C...Only give errors for large pT, otherwise just warnings
      DATA PTEMAX /5D0/
 
      IFAIL=-1
 
C----------------------------------------------------------------------
C...MODE=-1: Initialize initial state showers from scratch, i.e.
C...starting from the hardest interaction initiators.
      IF (MODE.EQ.-1) THEN
C...Set hard scattering SHAT.
        SHTNOW(1)=VINT(44)
C...Mass thresholds and Lambda for QCD evolution.
        AEM2PI=PARU(101)/PARU(2)
        RMB=PMAS(5,1)
        RMC=PMAS(4,1)
        ALAM4=PARP(61)
        IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
        IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
        ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
        ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
C...Optionally use Lambda_MC = Lambda_CMW 
        IF (MSTP(64).EQ.3) THEN
          ALAM5 = ALAM5 * 1.569 
          ALAM4 = ALAM4 * 1.618 
          ALAM3 = ALAM3 * 1.661 
        ENDIF
        RMB2=RMB**2
        RMC2=RMC**2
C...Massive quark forced creation threshold (in M**2).
        TMIN=1.01D0
C...Set upper limit for X (ensures some X left for beam remnant).
        XMXC=1D0-2D0*PARP(111)/VINT(1)
 
        IF (MSTP(61).GE.1) THEN
C...Initial values: flavours, momenta, virtualities.
          DO 100 JS=1,2
            NISGEN(JS,1)=0
 
C...Special kinematics check for c/b quarks (that g -> c cbar or
C...b bbar kinematically possible).
            KFLB=K(IMI(JS,1,1),2)
            KFLCB=IABS(KFLB)
            IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
C...Check PT2MAX > mQ^2
              IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
                CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
     &               'No Q creation possible.')
                MINT(51)=1
                RETURN
              ELSE
C...Check for physical z values (m == MQ / sqrt(s))
C...For creation diagram, x < z < (1-m)/(1+m(1-m))
                FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
                ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
                IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
                  CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
     &                 'Q creation.')
                  MINT(51)=1
                  RETURN
                ENDIF
              ENDIF
            ENDIF
  100     CONTINUE
        ENDIF
 
        MINT(354)=0
C...Zero joining array
        DO 110 MJ=1,240
          MJOIND(1,MJ)=0
          MJOIND(2,MJ)=0
  110   CONTINUE
 
C----------------------------------------------------------------------
C...MODE= 0: Generate a trial branching on interaction MINT(36) side
C...MINT(30). Store if emission PT2 scale is largest so far.
C...Also generate test joinings if MSTP(96)=1.
      ELSEIF(MODE.EQ.0) THEN
        IFAIL=-1
        MECOR=0
        ISUB=MINT(1)
        JS=MINT(30)
C...No shower for structureless beam
        IF (MINT(44+JS).EQ.1) RETURN
        MI=MINT(36)
        SHAT=VINT(44)
C...Absolute shower max scale = VINT(56)
        PT2=MIN(PT2NOW,VINT(56))
        IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
C...Define for which processes ME corrections have been implemented.
        IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
          IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
     &         .142.OR.ISUB.EQ.144) MECOR=1
          IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
          IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
C...Calculate preweighting factor for ME-corrected processes.
          IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
        ENDIF
C...Basic info on daughter for which to find mother.
        KFLB=K(IMI(JS,MI,1),2)
        KFLBA=IABS(KFLB)
C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
C...second companion.
        KSVCB=MAX(-1,IMI(JS,MI,2))
C...Treat "first" companion of a pair like an ordinary sea quark
C...(except that creation diagram is not allowed)
        IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
C...X (rescaled to [0,1])
        XB=XMI(JS,MI)/VINT(142+JS)
C...Massive quarks (use physical masses.)
        RMQ2=0D0
        MQMASS=0
        IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
          RMQ2=RMC2
          IF (KFLBA.EQ.5) RMQ2=RMB2
C...Special threshold treatment for non-photon beams
          IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
        ENDIF
 
C...Flags for parton distribution calls.
        MINT(105)=MINT(102+JS)
        MINT(109)=MINT(106+JS)
        VINT(120)=VINT(2+JS)
 
C...Calculate initial parton distribution weights.
        IF(XB.GE.XMXC) THEN
          RETURN
        ELSEIF(MQMASS.EQ.0) THEN
          CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
        ELSE
C...Initialize massive quark PT2 dependent pdf underestimate.
          PT20=PT2
          CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
C.!.Tentative treatment of massive valence quarks.
          XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
          XG0=XFB(21)
          TPM0=LOG(PT20/RMQ2)
          WPDF0=TPM0*XG0/XQ0
        ENDIF
        IF (KFLBA.LE.6) THEN
C...For quarks, only include respective sea, val, or cmp part.
          IF (KSVCB.LE.0) THEN
            XFB(KFLB)=XPSVC(KFLB,KSVCB)
          ELSE
C...Find companion's companion
            MISEA=0
  120       MISEA=MISEA+1
            IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
            XS=XMI(JS,MISEA)
            XREM=VINT(142+JS)
            YS=XS/(XREM+XS)
C...Momentum fraction of the companion quark.
C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
            YB=XB*(1D0-YS)
            XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
          ENDIF
        ENDIF
 
C...Determine overestimated z range: switch at c and b masses.
  130   IF (PT2.GT.TMIN*RMB2) THEN
          IZRG=3
          PT2MNE=MAX(TMIN*RMB2,PT2CUT)
          B0=23D0/6D0
          ALAM2=ALAM5**2
        ELSEIF(PT2.GT.TMIN*RMC2) THEN
          IZRG=2
          PT2MNE=MAX(TMIN*RMC2,PT2CUT)
          B0=25D0/6D0
          ALAM2=ALAM4**2
        ELSE
          IZRG=1
          PT2MNE=PT2CUT
          B0=27D0/6D0
          ALAM2=ALAM3**2
        ENDIF
C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
        ALAM2=ALAM2/PARP(64)
C...Overestimated ZMAX:
        IF (MQMASS.EQ.0) THEN
C...Massless
          ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
     &         /PT2MNE)-1D0)
        ELSE
C...Massive (limit for bremsstrahlung diagram > creation)
          FMQ=SQRT(RMQ2/SHTNOW(MI))
          ZMAX=1D0/(1D0+FMQ)
        ENDIF
        ZMIN=XB/XMXC
 
C...If kinematically impossible then do not evolve.
        IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
 
C...Reset Altarelli-Parisi and PDF weights.
        DO 140 KFL=-5,5
          WTAP(KFL)=0D0
          WTPDF(KFL)=0D0
  140   CONTINUE
        WTAP(21)=0D0
        WTPDF(21)=0D0
C...Zero joining weights and compute X(partner) and X(mother) values.
        IF (MSTP(96).NE.0) THEN
          NJN=0
          DO 150 MJ=1,MINT(31)
            WTAPJ(MJ)=0D0
            WTPDFJ(MJ)=0D0
            X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
            Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
     &           +XMI(JS,MI))
  150     CONTINUE
        ENDIF
 
C...Approximate Altarelli-Parisi weights (integrated AP dz).
C...q -> q, g -> q or q -> q + gamma (already set which).
        IF(KFLBA.LE.5) THEN
C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
          IF (KSVCB.LT.0) THEN
            WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
          ELSE
            RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
            RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
            WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
          ENDIF
          WTAP(21)=0.5D0*(ZMAX-ZMIN)
          WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
          IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
          IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
            WTAP(KFLB)=WTFF*WTAP(KFLB)
            WTAP(21)=WTGF*WTAP(21)
            WTAPE=WTFF*WTAPE
          ENDIF
          IF (KSVCB.GE.1) THEN
C...Kill normal creation but add joining diagrams for cmp quark.
            WTAP(21)=0D0
            IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
              CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
     &             " quark here. Not handled yet, giving up!")
              PT2=0D0
              MINT(51)=1
              RETURN
            ENDIF
C...Check for possible joinings
            IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
C...Find companion's companion.
              MJ=0
  160         MJ=MJ+1
              IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
              IF (MJOIND(JS,MJ).EQ.0) THEN
                Y(MI)=YB+YS
                Z=YB/Y(MI)
                WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
                IF (WTAPJ(MJ).GT.1D-6) THEN
                  NJN=1
                ELSE
                  WTAPJ(MJ)=0D0
                ENDIF
              ENDIF
C...Add trial gluon joinings.
              DO 170 MJ=1,MINT(31)
                KFLC=K(IMI(JS,MJ,1),2)
                IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
                Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
                WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
                IF (WTAPJ(MJ).GT.1D-6) THEN
                  NJN=NJN+1
                ELSE
                  WTAPJ(MJ)=0D0
                ENDIF
  170         CONTINUE
            ENDIF
          ELSEIF (IMI(JS,MI,2).GE.0) THEN
C...Kill creation diagram for val quarks and sea quarks with companions.
            WTAP(21)=0D0
          ELSEIF (MQMASS.EQ.0) THEN
C...Extra safety factor for massless sea quark creation.
            WTAP(21)=WTAP(21)*1.25D0
          ENDIF
 
C...  q -> g, g -> g.
        ELSEIF(KFLB.EQ.21) THEN
C...Here we decide later whether a quark picked up is valence or
C...sea, so we maintain the extra factor sqrt(z) since we deal
C...with the *sum* of sea and valence in this context.
          WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
C...new: do not allow backwards evol to pick up heavy flavour.
          DO 180 KFL=1,MIN(3,MSTP(58))
            WTAP(KFL)=WTAPQ
            WTAP(-KFL)=WTAPQ
  180     CONTINUE
          WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
          IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
            WTAPQ=WTFG*WTAPQ
            WTAP(21)=WTGG*WTAP(21)
          ENDIF
C...Check for possible joinings (companions handled separately above)
          IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
     &         THEN
            DO 190 MJ=1,MINT(31)
              IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
              KSVCC=IMI(JS,MJ,2)
              IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
              IF (KSVCC.GE.1) GOTO 190
              KFLC=K(IMI(JS,MJ,1),2)
C...Only try g -> g + g once.
              IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
              Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
              IF (KFLC.EQ.21) THEN
                WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
              ELSE
                WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
              ENDIF
              IF (WTAPJ(MJ).GT.1D-6) THEN
                NJN=NJN+1
              ELSE
                WTAPJ(MJ)=0D0
              ENDIF
  190       CONTINUE
          ENDIF
        ENDIF
 
C...Initialize massive quark evolution
        IF (MQMASS.NE.0) THEN
          RML=(RMQ2+VINT(18))/ALAM2
          TML=LOG(RML)
          TPL=LOG((PT2+VINT(18))/ALAM2)
          TPM=LOG((PT2+VINT(18))/RMQ2)
          WN=WTAP(21)*WPDF0/B0
        ENDIF
 
 
C...Loopback point for iteration
        NTRY=0
        NTHRES=0
  200   NTRY=NTRY+1
        IF(NTRY.GT.500) THEN
          CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
          MINT(51)=1
          RETURN
        ENDIF
 
C...  Calculate PDF weights and sum for evolution rate.
        WTSUM=0D0
        XFBO=MAX(1D-10,XFB(KFLB))
        DO 210 KFL=-5,5
          WTPDF(KFL)=XFB(KFL)/XFBO
          WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
  210   CONTINUE
C...Only add gluon mother diagram for massless KFLB.
        IF(MQMASS.EQ.0) THEN
          WTPDF(21)=XFB(21)/XFBO
          WTSUM=WTSUM+WTAP(21)*WTPDF(21)
        ENDIF
        WTSUM=MAX(0.0001D0,WTSUM)
        WTSUMS=WTSUM
C...Add joining diagrams where applicable.
        WTJOIN=0D0
        IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
          DO 220 MJ=1,MINT(31)
            IF (WTAPJ(MJ).LT.1D-3) GOTO 220
            WTPDFJ(MJ)=1D0/XFBO
C...x and x*pdf (+ sea/val) for parton C.
            KFLC=K(IMI(JS,MJ,1),2)
            KFLCA=IABS(KFLC)
            KSVCC=MAX(-1,IMI(JS,MJ,2))
            IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
            MINT(30)=JS
            MINT(36)=MJ
            CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
            MINT(36)=MI
            IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
              XFJ(KFLC)=XPSVC(KFLC,KSVCC)
            ELSEIF (KSVCC.GE.1) THEN
              print*, 'error! parton C is companion!'
            ENDIF
            WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
C...x and x*pdf (+ sea/val) for parton A.
            KFLA=21
            KSVCA=0
            IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
              KFLA=KFLB
              KSVCA=KSVCB
            ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
              KFLA=KFLC
              KSVCA=KSVCC
            ENDIF
            MINT(30)=JS
            IF (KSVCA.LE.0) THEN
C...Consider C the "evolved" parton if B is gluon. Val/sea
C...counting will then be done correctly in PYPDFU.
              IF (KFLBA.EQ.21) MINT(36)=MJ
              CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
              MINT(36)=MI
              IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
            ELSE
C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
              XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
            ENDIF
            WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
            WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
  220     CONTINUE
        ENDIF
 
C...Pick normal pT2 (in overestimated z range).
  230   PT2OLD=PT2
        WTSUM=WTSUMS
        PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
        KFLC=21
 
C...Evolve q -> q gamma separately, pick it if larger pT.
        IF(KFLBA.LE.5) THEN
          PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
          IF(PT2QED.GT.PT2) THEN
            PT2=PT2QED
            KFLC=22
            KFLA=KFLB
          ENDIF
        ENDIF
 
C...  Evolve massive quark creation separately.
        MCRQQ=0
        IF (MQMASS.NE.0) THEN
          PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
     &         -VINT(18)
C...  Ensure mininimum PT2CR and force creation near threshold.
          IF (PT2CR.LT.TMIN*RMQ2) THEN
            NTHRES=NTHRES+1
            IF (NTHRES.GT.50) THEN
              CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
     &             'massive quark creation. Gave up trying.')
              MINT(51)=1
C...Special return code if failing before any evolution at all: bad event
              IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
              RETURN
            ENDIF
            PT2=0D0
            PT2CR=TMIN*RMQ2
            MCRQQ=2
          ENDIF
C...  Select largest PT2 (brems or creation):
          IF (PT2CR.GT.PT2) THEN
            MCRQQ=MAX(MCRQQ,1)
            WTSUM=0D0
            PT2=PT2CR
            KFLA=21
          ELSE
            MCRQQ=0
            KFLA=KFLB
          ENDIF
C...  Compute logarithms for this PT2
          TPL=LOG((PT2+VINT(18))/ALAM2)
          TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
          WTCRQQ=TPM/LOG(PT2/RMQ2)
        ENDIF
 
C...Evolve joining separately
        MJOIN=0
        IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
          PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
     &         -VINT(18)
          IF (PT2JN.GE.PT2) THEN
            MJOIN=1
            PT2=PT2JN
          ENDIF
        ENDIF
 
C...Loopback if crossed c/b mass thresholds.
        IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
          PT2=RMB2
         GOTO 130
        ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
          PT2=RMC2
          GOTO 130
        ENDIF
 
C...Speed up shower. Skip if higher-PT acceptable branching
C...already found somewhere else.
C...Also finish if below lower cutoff.
 
        IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
 
C...Select parton A flavour (massive Q handled above.)
        IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
          WTRAN=PYR(0)*WTSUM
          KFLA=-6
  240     KFLA=KFLA+1
          WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
          IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
          IF(KFLA.EQ.6) KFLA=21
        ELSEIF (MJOIN.EQ.1) THEN
C...Tentative joining accept/reject.
          WTRAN=PYR(0)*WTJOIN
          MJ=0
  250     MJ=MJ+1
          WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
          IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
          IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
            CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
     &           ' Rejected.')
            GOTO 230
          ENDIF
C...x*pdf (+ sea/val) at new pT2 for parton B.
          IF (KSVCB.LE.0) THEN
            MINT(30)=JS
            CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
            IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
          ELSE
C...Companion distributions do not evolve.
            XFB(KFLB)=XFBO
          ENDIF
          WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
          KFLC=K(IMI(JS,MJ,1),2)
          KFLCA=IABS(KFLC)
          KSVCC=MAX(-1,IMI(JS,MJ,2))
          IF (KSVCB.GE.1) KSVCC=-1
C...x*pdf (+ sea/val) at new pT2 for parton C.
          MINT(30)=JS
          MINT(36)=MJ
          CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
          MINT(36)=MI
          IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
          WTVETO=WTVETO/XFJ(KFLC)
C...x and x*pdf (+ sea/val) at new pT2 for parton A.
          KFLA=21
          KSVCA=0
          IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
            KFLA=KFLB
            KSVCA=KSVCB
          ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
            KFLA=KFLC
            KSVCA=KSVCC
          ENDIF
          IF (KSVCA.LE.0) THEN
            MINT(30)=JS
            IF (KFLB.EQ.21) MINT(36)=MJ
            CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
            MINT(36)=MI
            IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
          ELSE
            XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
          ENDIF
          WTVETO=WTVETO*XFJ(KFLA)
C...Monte Carlo veto.
          IF (WTVETO.LT.PYR(0)) GOTO 200
C...If accept, save PT2 of this joining.
          IF (PT2.GT.PT2MX) THEN
            PT2MX=PT2
            JSMX=2+JS
            MJN1MX=MJ
            MJN2MX=MI
            WTAPJ(MJ)=0D0
            NJN=0
          ENDIF
C...Exit and continue evolution.
          GOTO 390
        ENDIF
        KFLAA=IABS(KFLA)
 
C...Choose z value (still in overestimated range) and corrective weight.
C...Unphysical z will be rejected below when Q2 has is computed.
        WTZ=0D0
 
C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
C...q -> q + g or q -> q + gamma (already set which).
        IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
          IF (KSVCB.LT.0) THEN
            Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
          ELSE
            ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
            Z=((1-ZFAC)/(1+ZFAC))**2
          ENDIF
          WTZ=0.5D0*(1D0+Z**2)
C...Massive weight correction.
          IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
C...Valence quark weight correction (extra sqrt)
          IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
 
C...q -> g + q.
C...NB: MQ>0 not yet implemented. Forced absent above.
        ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
          KFLC=KFLA
          Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
          WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
 
C...g -> q + qbar.
        ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
          KFLC=-KFLB
          Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
          WTZ=Z**2+(1D0-Z)**2
C...Massive correction
          IF (MQMASS.NE.0) THEN
            WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
C...Extra safety margin for light sea quark creation
          ELSEIF (KSVCB.LT.0) THEN
            WTZ=WTZ/1.25D0
          ENDIF
 
C...g -> g + g.
        ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
          KFLC=21
          Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
     &         (ZMAX*(1D0-ZMIN)))**PYR(0))
          WTZ=(1D0-Z*(1D0-Z))**2
        ENDIF
 
C...Derive Q2 from pT2.
        Q2B=PT2/(1D0-Z)
        IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
 
C...Loopback if outside allowed z range for given pT2.
        RM2C=PYMASS(KFLC)**2
        PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
        IF (PT2ADJ.LT.1D-6) GOTO 230
 
C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
C...No modification for very first emission if using ME correction
        MSTP67 = MSTP(67)
        IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
          MSTP67 = 0
        ENDIF
 
C...For 1st branching, limit phase space by s-hat with color-partner
        IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
          MSIDE=1
          IDIP=IMI(JS,MI,1)
C...Use anticolor tag for antiquark, or for gluon half the time
          IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
     &        KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
C...Tag
          MCTAG=MCT(IDIP,MSIDE)
C...Default is to set up phase space using the opposite incoming parton
          JDIP=IMI(3-JS,MI,1)
          NDIP=0
C...Alternatively, look for final-state color partner (pick first if several)
          DO 260 IFS=1,NPART
            IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
              JDIP=IPART(IFS)
              NDIP=NDIP+1
            ENDIF
  260     CONTINUE
C...Compute mass of pair
          SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
     &        -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
          IF (MSTP67.EQ.1) THEN
C...1 Option to completely kill radiation above s_dip * PARP(67)
            IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
          ELSE IF (MSTP67.EQ.2) THEN
C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
C...  (-> improved power showers?)
            IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
          ENDIF
 
C...For subsequent branchings, loopback if nonordered in angle/rapidity
        ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
          IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
     &         GOTO 230
        ENDIF
 
C...Select phi angle of branching at random.
        PHI=PARU(2)*PYR(0)
 
C...Matrix-element corrections for some processes.
        IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
          IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
            CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
            WTZ=WTZ*WTME/WTFF
          ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
            CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
            WTZ=WTZ*WTME/WTGF
          ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
            CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
            WTZ=WTZ*WTME/WTFG
          ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
            CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
            WTZ=WTZ*WTME/WTGG
          ENDIF
        ENDIF
 
C...Parton distributions at new pT2 but old x.
        MINT(30)=JS
        CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
C...Treat val and cmp separately
        IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
        IF (KSVCB.GE.1)
     &       XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
        XFBN=XFN(KFLB)
        IF(XFBN.LT.1D-20) THEN
          IF(KFLA.EQ.KFLB) THEN
            WTAP(KFLB)=0D0
            GOTO 200
          ELSE
            XFBN=1D-10
            XFN(KFLB)=XFBN
          ENDIF
        ENDIF
        DO 270 KFL=-5,5
          XFB(KFL)=XFN(KFL)
  270   CONTINUE
        XFB(21)=XFN(21)
 
C...Parton distributions at new pT2 and new x.
        XA=XB/Z
        MINT(30)=JS
        CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
        IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
C...q -> q + g: only consider respective sea, val, or cmp content.
          IF (KSVCB.LE.0) THEN
            XFA(KFLA)=XPSVC(KFLA,KSVCB)
          ELSE
            YA=XA*(1D0-YS)
            XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
          ENDIF
        ENDIF
        XFAN=XFA(KFLA)
        IF(XFAN.LT.1D-20) THEN
          GOTO 200
        ENDIF
 
C...If weighting fails continue evolution.
        WTTOT=0D0
        IF (MCRQQ.EQ.0) THEN
          WTPDFA=1D0/WTPDF(KFLA)
          WTTOT=WTZ*XFAN/XFBN*WTPDFA
        ELSEIF(MCRQQ.EQ.1) THEN
          WTPDFA=TPM/WPDF0
          WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
          XBEST=TPM/TPM0*XQ0
        ELSEIF(MCRQQ.EQ.2) THEN
C...Force massive quark creation.
          WTTOT=1D0
        ENDIF
 
C...Loop back if trial emission fails.
        IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
        WTACC=((1D0+PT2)/(0.25D0+PT2))**2
        IF(WTTOT.LT.0D0) THEN
          WRITE(CHWT,'(1P,E12.4)') WTTOT
          CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
        ELSEIF(WTTOT.GT.WTACC) THEN
          WRITE(CHWT,'(1P,E12.4)') WTTOT
          IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
C...Too high weight: write out as error, but do not update error counter
            IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
            CALL PYERRM(19,
     &         '(PYPTIS:) Weight '//CHWT//' above unity')
            IF (PT2.GT.PTEMAX) PTEMAX=PT2
            IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
          ELSE
            CALL PYERRM(9,
     &         '(PYPTIS:) Weight '//CHWT//' above unity')
          ENDIF
C...Useful for debugging but commented out for distribution:
C          print*, 'JS, MI',JS, MI
C          print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
C          print*, 'A -> B C',KFLA, KFLB, KFLC
C          XFAO=XFBO/WTPDFA
C          print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
        ENDIF
 
C...Save acceptable branching.
        IF(PT2.GT.PT2MX) THEN
          MIMX=MINT(36)
          JSMX=JS
          PT2MX=PT2
          KFLAMX=KFLA
          KFLCMX=KFLC
          RM2CMX=RM2C
          Q2BMX=Q2B
          ZMX=Z
          PT2AMX=PT2ADJ
          PHIMX=PHI
        ENDIF
 
C----------------------------------------------------------------------
C...MODE= 1: Accept stored shower branching. Update event record etc.
      ELSEIF (MODE.EQ.1) THEN
        MI=MIMX
        JS=JSMX
        SHAT=SHTNOW(MI)
        SIDE=3D0-2D0*JS
C...Shift down rest of event record to make room for insertion.
        IT=IMISEP(MI)+1
        IM=IT+1
        IS=IMI(JS,MI,1)
        DO 290 I=N,IT,-1
          IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
          KT1=K(I,4)/MSTU(5)**2
          KT2=K(I,5)/MSTU(5)**2
          ID1=MOD(K(I,4),MSTU(5))
          ID2=MOD(K(I,5),MSTU(5))
          IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
          IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
          IF (ID1.GE.IT) ID1=ID1+2
          IF (ID2.GE.IT) ID2=ID2+2
          IF (IM1.GE.IT) IM1=IM1+2
          IF (IM2.GE.IT) IM2=IM2+2
          K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
          K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
          DO 280 IX=1,5
            K(I+2,IX)=K(I,IX)
            P(I+2,IX)=P(I,IX)
            V(I+2,IX)=V(I,IX)
  280     CONTINUE
          MCT(I+2,1)=MCT(I,1)
          MCT(I+2,2)=MCT(I,2)
  290   CONTINUE
        N=N+2
C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
        DO 300 JI=1,MINT(31)
          IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
          IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
          IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
          IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
          IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
C...Also update companion pointers to the present mother.
          IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
  300   CONTINUE
        DO 310 IFS=1,NPART
          IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
  310   CONTINUE
C...Zero entries dedicated for new timelike and mother partons.
        DO 330 I=IT,IT+1
          DO 320 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  320     CONTINUE
          MCT(I,1)=0
          MCT(I,2)=0
  330   CONTINUE
 
C...Define timelike and new mother partons. History.
        K(IT,1)=3
        K(IT,2)=KFLCMX
        K(IM,1)=14
        K(IM,2)=KFLAMX
        K(IS,3)=IM
        K(IT,3)=IM
C...Set mother origin = side.
        K(IM,3)=MINT(83)+JS+2
        IF(MI.GE.2) K(IM,3)=MINT(83)+JS
 
C...Define colour flow of branching.
        IM1=IM
        IM2=IM
C...q -> q + gamma.
        IF(K(IT,2).EQ.22) THEN
          K(IT,1)=1
          ID1=IS
          ID2=IS
C...q -> q + g.
        ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
          ID1=IT
          ID2=IS
C...q -> g + q.
        ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
          ID1=IS
          ID2=IT
C...qbar -> qbar + g.
        ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
          ID1=IS
          ID2=IT
C...qbar -> g + qbar.
        ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
          ID1=IT
          ID2=IS
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
          ID2=IT
        ELSE
          ID1=IT
          ID2=IS
        ENDIF
        IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
        IF(IM2.EQ.IM) 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
        IF(K(IT,1).EQ.1) THEN
          K(IT,4)=0
          K(IT,5)=0
        ENDIF
C...Update IMI and colour tag arrays.
        IMI(JS,MI,1)=IM
        DO 340 MC=1,2
          MCT(IT,MC)=0
          MCT(IM,MC)=0
  340   CONTINUE
        DO 350 JCS=4,5
          KCS=JCS
C...If mother flag not yet set for spacelike parton, trace it.
          IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
          IF(MINT(51).NE.0) RETURN
  350   CONTINUE
        DO 360 JCS=4,5
          KCS=JCS
C...If mother flag not yet set for timelike parton, trace it.
          IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
          IF(MINT(51).NE.0) RETURN
  360   CONTINUE
 
C...Boost recoiling parton to compensate for Q2 scale.
        BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
     &  (1D0+(1D0+Q2BMX/SHAT)**2)
        IR=IMI(3-JS,MI,1)
        CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
 
C...Define system to be rotated and boosted
C...(not including the 2 just added partons)
C...(but including the docu lines for first interaction)
        IMIN=IMISEP(MI-1)+1
        IF (MI.EQ.1) IMIN=MINT(83)+5
        IMAX=IMISEP(MI)-2
 
C...Rotate back system in phi to compensate for subsequent rotation.
        CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
 
C...Define kinematics of new partons in old frame.
        IMAX=IMISEP(MI)
        P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
        P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
     &       +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
        P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
        P(IT,1)=P(IM,1)
        P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
        P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
        P(IT,5)=SQRT(RM2CMX)
 
C...Update internal line, now spacelike
        P(IS,1)=P(IM,1)-P(IT,1)
        P(IS,2)=P(IM,2)-P(IT,2)
        P(IS,3)=P(IM,3)-P(IT,3)
        P(IS,4)=P(IM,4)-P(IT,4)
        P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
        IF (P(IS,5).LT.0D0) THEN
          P(IS,5)=-SQRT(ABS(P(IS,5)))
        ELSE
          P(IS,5)=SQRT(P(IS,5))
        ENDIF
 
C...Boost entire system and rotate to new frame.
C...(including docu lines)
        BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
        BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
        IF(BETAX**2+BETAZ**2.GE.1D0) THEN
          CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
          MINT(51)=1
          IFAIL=-1
          RETURN
        ENDIF
        CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
        I1=IMI(1,MI,1)
        THETA=PYANGL(P(I1,3),P(I1,1))
        CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
 
C...Global statistics.
        MINT(352)=MINT(352)+1
        VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
        IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
 
C...Add parton with relevant pT scale for timelike shower.
        IF (K(IT,2).NE.22) THEN
          NPART=NPART+1
          IPART(NPART)=IT
          PTPART(NPART)=SQRT(PT2AMX)
        ENDIF
 
C...Update saved variables.
        SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
        NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
        XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
        PT2SAV(JSMX,MIMX)=PT2MX
        ZSAV(JS,MIMX)=ZMX
 
        KSA=IABS(K(IS,2))
        KMA=IABS(K(IM,2))
        IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
C...Gluon reconstructs to quark.
C...Decide whether newly created quark is valence or sea:
          MINT(30)=JS
          CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
          IF(MINT(51).NE.0) RETURN
        ENDIF
        IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
C...Quark reconstructs to gluon.
C...Now some guy may have lost his companion. Check.
          ICMP=IMI(JS,MI,2)
          IF (ICMP.GT.0) THEN
            CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
     &           //' away. Cannot handle that yet. Giving up.')
            MINT(51)=1
            RETURN
          ELSEIF(ICMP.LT.0) THEN
C...A sea quark with companion still in BR was reconstructed to a gluon.
C...Companion should now be removed from the beam remnant.
C...(Momentum integral is automatically updated in next call to PYPDFU.)
            ICMP=-ICMP
            IFL=-K(IS,2)
            DO 380 JCMP=ICMP,NVC(JS,IFL)-1
              XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
              DO 370 JI=1,MINT(31)
                KMI=-IMI(JS,JI,2)
                JFL=-K(IMI(JS,JI,1),2)
                IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
     &               ,2)+1
  370         CONTINUE
  380       CONTINUE
            NVC(JS,IFL)=NVC(JS,IFL)-1
          ENDIF
C...Set gluon IMI(JS,MI,2) = 0.
          IMI(JS,MI,2)=0
        ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
C...Quark reconstructing to quark. If sea with companion still in BR
C...then update associated x value.
C...(Momentum integral is automatically updated in next call to PYPDFU.)
          IF (IMI(JS,MI,2).LT.0) THEN
            ICMP=-IMI(JS,MI,2)
            IFL=-K(IS,2)
            XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
          ENDIF
        ENDIF
 
      ENDIF
 
C...If reached this point, normal exit.
  390 IFAIL=0
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMEMX
C...Generates maximum ME weight in some initial-state showers.
C...Inparameter MECOR: kind of hard scattering process
C...Outparameter WTFF: maximum weight for fermion -> fermion
C...             WTGF: maximum weight for gluon/photon -> fermion
C...             WTFG: maximum weight for fermion -> gluon/photon
C...             WTGG: maximum weight for gluon -> gluon
 
      SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
 
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)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
 
C...Default maximum weight.
      WTFF=1D0
      WTGF=1D0
      WTFG=1D0
      WTGG=1D0
 
C...Select maximum weight by process.
      IF(MECOR.EQ.1) THEN
        WTFF=1D0
        WTGF=3D0
      ELSEIF(MECOR.EQ.2) THEN
        WTFG=1D0
        WTGG=1D0
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMEWT
C...Calculates actual ME weight in some initial-state showers.
C...Inparameter MECOR: kind of hard scattering process
C...            IFLCB: flavour combination of branching,
C...                   1 for fermion -> fermion,
C...                   2 for gluon/photon -> fermion
C...                   3 for fermion -> gluon/photon,
C...                   4 for gluon -> gluon
C...            Q2:    Q2 value of shower branching
C...            Z:     Z value of branching
C...In+outparameter PHIBR: azimuthal angle of branching
C...Outparameter WTME: actual ME weight
 
      SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
 
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)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
 
C...Default output.
      WTME=1D0
 
C...Define kinematics of shower branching in Mandelstam variables.
      SQM=VINT(44)
      SH=SQM/Z
      TH=-Q2
      UH=Q2-SQM*(1D0-Z)/Z
 
C...Matrix-element corrections for f + fbar -> s-channel vector boson.
      IF(MECOR.EQ.1) THEN
        IF(IFLCB.EQ.1) THEN
          WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
        ELSEIF(IFLCB.EQ.2) THEN
          WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
        ENDIF
 
C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
      ELSEIF(MECOR.EQ.2) THEN
        IF(IFLCB.EQ.3) THEN
          WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
        ELSEIF(IFLCB.EQ.4) THEN
          WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
        ENDIF

C...Matrix-element corrections for q + qbar -> Higgs (h0)
      ELSEIF(MECOR.EQ.3) THEN
        IF(IFLCB.EQ.2) THEN
          WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
     1      (SH**2+2D0*SQM*(SQM-SH))
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPTMI
C...Handles the generation of additional interactions in the new
C...multiple interactions framework.
C...MODE=-1 : Initalize MI from scratch.
C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
C...         Sudakov for PT2, abort if below PT2CUT.
C...MODE= 1 : Accept interaction at PT2NOW and store variables.
C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
C...PT2NOW  : Starting (max) PT2 scale for evolution.
C...PT2CUT  : Lower limit for evolution.
C...PT2     : Result of evolution. Generated PT2 for trial interaction.
C...IFAIL   : Status return code.
C...         = 0: All is well.
C...         < 0: Phase space exhausted, generation to be terminated.
C...         > 0: Additional interaction vetoed, but continue evolution.
 
      SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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(8000,2),BRAT(8000),KFDP(8000,5)
      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)
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
     &     PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
      COMMON/PYCTAG/NCT,MCT(4000,2)
C...Local arrays and saved variables.
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
 
      SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
     &     /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
     &     /PYISMX/,/PYCTAG/
      SAVE XT2FAC,SIGS
 
      IFAIL=0
C...Set MI subprocess = QCD 2 -> 2.
      ISUB=96
 
C----------------------------------------------------------------------
C...MODE=-1: Initialize from scratch
      IF (MODE.EQ.-1) THEN
C...Initialize PT2 array.
        PT2MI(1)=VINT(54)
C...Initialize list of incoming beams and partons from two sides.
        DO 110 JS=1,2
          DO 100 MI=1,240
            IMI(JS,MI,1)=0
            IMI(JS,MI,2)=0
  100     CONTINUE
          NMI(JS)=1
          IMI(JS,1,1)=MINT(84)+JS
          IMI(JS,1,2)=0
          XMI(JS,1)=VINT(40+JS)
C...Rescale x values to fractions of photon energy.
          IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
C...Hard reset: hard interaction initiators motherless by definition.
          K(MINT(84)+JS,3)=2+JS
          K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
          K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
  110   CONTINUE
        IMISEP(0)=MINT(84)
        IMISEP(1)=N
        IF (MOD(MSTP(81),10).GE.1) THEN
          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
        ENDIF
C...Zero entries relating to scatterings beyond the first.
        DO 120 MI=2,240
          IMI(1,MI,1)=0
          IMI(2,MI,1)=0
          IMI(1,MI,2)=0
          IMI(2,MI,2)=0
          IMISEP(MI)=IMISEP(1)
          PT2MI(MI)=0D0
          XMI(1,MI)=0D0
          XMI(2,MI)=0D0
  120   CONTINUE
C...Initialize factors for PDF reshaping.
        DO 140 JS=1,2
          KFBEAM(JS)=MINT(10+JS)
          IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
          KFABM=IABS(KFBEAM(JS))
          KFSBM=ISIGN(1,KFBEAM(JS))
 
C...Zero flavour content of incoming beam particle.
          KFIVAL(JS,1)=0
          KFIVAL(JS,2)=0
          KFIVAL(JS,3)=0
C...  Flavour content of baryon.
          IF(KFABM.GT.1000) THEN
            KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
            KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
            KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
C...  Flavour content of pi+-, K+-.
          ELSEIF(KFABM.EQ.211) THEN
            KFIVAL(JS,1)=KFSBM*2
            KFIVAL(JS,2)=-KFSBM
          ELSEIF(KFABM.EQ.321) THEN
            KFIVAL(JS,1)=-KFSBM*3
            KFIVAL(JS,2)=KFSBM*2
C...  Flavour content of pi0, gamma, K0S, K0L not defined yet.
          ENDIF
 
C...Zero initial valence and companion content.
          DO 130 IFL=-6,6
            NVC(JS,IFL)=0
  130     CONTINUE
  140   CONTINUE
C...Set up colour line tags starting from hard interaction initiators.
        NCT=0
C...Reset colour tag array and colour processing flags.
        DO 150 I=IMISEP(0)+1,N
          MCT(I,1)=0
          MCT(I,2)=0
          K(I,4)=MOD(K(I,4),MSTU(5)**2)
          K(I,5)=MOD(K(I,5),MSTU(5)**2)
  150   CONTINUE
C...  Consider each side in turn.
        DO 170 JS=1,2
          I1=IMI(JS,1,1)
          I2=IMI(3-JS,1,1)
          DO 160 JCS=4,5
            IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
     &           GOTO 160
            IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
            KCS=JCS
            CALL PYCTTR(I1,KCS,I2)
            IF(MINT(51).NE.0) RETURN
  160     CONTINUE
  170   CONTINUE
 
C...Range checking for companion quark pdf large-x param.
        IF (MSTP(87).LT.0) THEN
          CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
     &         ' MSTP(87)=0')
          MSTP(87)=0
        ELSEIF (MSTP(87).GT.4) THEN
          CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
     &         ' MSTP(87)=4')
          MSTP(87)=4
        ENDIF
 
C----------------------------------------------------------------------
C...MODE=0: Generate trial interaction. Return codes:
C...IFAIL < 0: Phase space exhausted, generation to be terminated.
C...IFAIL = 0: Additional interaction generated at PT2.
C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
      ELSEIF (MODE.EQ.0) THEN
C...Abolute MI max scale = VINT(62)
        XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
  180   IF(MSTP(82).LE.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
          IF(XT2.LT.VINT(149)) IFAIL=-2
        ELSE
          IF(XT2.LE.0.01001D0*VINT(149)) THEN
            IFAIL=-3
          ELSE
            XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
     &           LOG(PYR(0)))-VINT(149)
          ENDIF
        ENDIF
C...Also exit if below lower limit or if higher trial branching
C...already found.
        PT2=0.25D0*VINT(2)*XT2
        IF (PT2.LE.PT2CUT) IFAIL=-4
        IF (PT2.LE.PT2MX) IFAIL=-5
        IF (IFAIL.NE.0) THEN
          PT2=0D0
          RETURN
        ENDIF
        IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
        VINT(25)=4D0*PT2/VINT(2)
        XT2=VINT(25)
 
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
C...New: require shat > 1.
        IF(TAU*VINT(2).LT.1D0) GOTO 180
        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 180
        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 180
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
 
C...Save if highest PT so far.
        IF (PT2.GT.PT2MX) THEN
          JSMX=0
          MIMX=MINT(31)+1
          PT2MX=PT2
        ENDIF
 
C----------------------------------------------------------------------
C...MODE=1: Generate and save accepted scattering.
      ELSEIF (MODE.EQ.1) THEN
        PT2=PT2NOW
C...Reset K, P, V, and MCT vectors.
        DO 200 I=N+1,N+4
          DO 190 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  190     CONTINUE
          MCT(I,1)=0
          MCT(I,2)=0
  200   CONTINUE
 
        NTRY=0
C...Choose flavour of reacting partons (and subprocess).
  210   NTRY=NTRY+1
        IF (NTRY.GT.50) THEN
          CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
     &               //'interaction. Giving up!')
          MINT(51)=1
          RETURN
        ENDIF
        RSIGS=SIGS*PYR(0)
        DO 220 ICHN=1,NCHN
          KFL1=ISIG(ICHN,1)
          KFL2=ISIG(ICHN,2)
          ICONMI=ISIG(ICHN,3)
          RSIGS=RSIGS-SIGH(ICHN)
          IF(RSIGS.LE.0D0) GOTO 230
  220   CONTINUE
 
C...Reassign to appropriate process codes.
  230   ISUBMI=ICONMI/10
        ICONMI=MOD(ICONMI,10)
 
C...Choose new quark flavour for annihilation graphs
        IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
          SH=VINT(21)*VINT(2)
          CALL PYWIDT(21,SH,WDTP,WDTE)
  240     RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
          DO 250 I=1,MDCY(21,3)
            KFLF=KFDP(I+MDCY(21,2)-1,1)
            RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
            IF(RKFL.LE.0D0) GOTO 260
  250     CONTINUE
  260     IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
            IF(KFLF.GE.4) GOTO 240
          ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
            KFLF=4
            ICONMI=ICONMI-2
          ELSEIF(ISUBMI.EQ.53) THEN
            KFLF=5
            ICONMI=ICONMI-4
          ENDIF
        ENDIF
 
C...Final state flavours and colour flow: default values
        JS=1
        KFL3=KFL1
        KFL4=KFL2
        KCC=20
        KCS=ISIGN(1,KFL1)
 
        IF(ISUBMI.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
          KCC=ICONMI
          IF(KFL1*KFL2.LT.0) KCC=KCC+2
 
        ELSEIF(ISUBMI.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
          KFL3=ISIGN(KFLF,KFL1)
          KFL4=-KFL3
          KCC=4
 
        ELSEIF(ISUBMI.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
          KFL3=21
          KFL4=21
          KCC=ICONMI+4
 
        ELSEIF(ISUBMI.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
          IF(KFL1.EQ.21) JS=2
          KCC=ICONMI+6
          IF(KFL1.EQ.21) KCC=KCC+2
          IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
          IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
 
        ELSEIF(ISUBMI.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          KFL3=ISIGN(KFLF,KCS)
          KFL4=-KFL3
          KCC=ICONMI+10
 
        ELSEIF(ISUBMI.EQ.68) THEN
C...g + g -> g + g; th arbitrary
          KCC=ICONMI+12
          KCS=(-1)**INT(1.5D0+PYR(0))
        ENDIF
 
C...Check that massive sea quarks have non-zero phase space for g -> Q Q
        IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
     &       .OR.IABS(KFL4).EQ.5) THEN
          RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
          IF (PT2.LE.1.05*RMMAX2) THEN
            IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
     &           //' too close to threshold (2nd try).')
            GOTO 210
          ENDIF
        ENDIF
 
C...Store flavours of scattering.
        MINT(13)=KFL1
        MINT(14)=KFL2
        MINT(15)=KFL1
        MINT(16)=KFL2
        MINT(21)=KFL3
        MINT(22)=KFL4
 
C...Set flavours and mothers of scattering partons.
        K(N+1,1)=14
        K(N+2,1)=14
        K(N+3,1)=3
        K(N+4,1)=3
        K(N+1,2)=KFL1
        K(N+2,2)=KFL2
        K(N+3,2)=KFL3
        K(N+4,2)=KFL4
        K(N+1,3)=MINT(83)+1
        K(N+2,3)=MINT(83)+2
        K(N+3,3)=N+1
        K(N+4,3)=N+2
 
C...Store colour connection indices.
        DO 270 J=1,2
          JC=J
          IF(KCS.EQ.-1) JC=3-J
          IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
          IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
          IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
          IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
  270   CONTINUE
 
C...Store incoming and outgoing partons in their CM-frame.
        SHR=SQRT(VINT(21))*VINT(1)
        P(N+1,3)=0.5D0*SHR
        P(N+1,4)=0.5D0*SHR
        P(N+2,3)=-0.5D0*SHR
        P(N+2,4)=0.5D0*SHR
        P(N+3,5)=PYMASS(K(N+3,2))
        P(N+4,5)=PYMASS(K(N+4,2))
        IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
          IFAIL=1
          RETURN
        ENDIF
        P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
        P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
        P(N+4,4)=SHR-P(N+3,4)
        P(N+4,3)=-P(N+3,3)
 
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
        PHI=PARU(2)*PYR(0)
        CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
 
C...Global statistics.
        MINT(351)=MINT(351)+1
        VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
        IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
 
C...Keep track of loose colour ends and information on scattering.
        MINT(31)=MINT(31)+1
        MINT(36)=MINT(31)
        PT2MI(MINT(36))=PT2
        IMISEP(MINT(31))=N+4
        DO 280 JS=1,2
          IMI(JS,MINT(31),1)=N+JS
          IMI(JS,MINT(31),2)=0
          XMI(JS,MINT(31))=VINT(40+JS)
          NMI(JS)=NMI(JS)+1
C...Update cumulative counters
          VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
          VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
  280   CONTINUE
 
C...Add to list of final state partons
        IPART(NPART+1)=N+3
        IPART(NPART+2)=N+4
        PTPART(NPART+1)=SQRT(PT2)
        PTPART(NPART+2)=SQRT(PT2)
        NPART=NPART+2
 
C...Initialize ISR
        NISGEN(1,MINT(31))=0
        NISGEN(2,MINT(31))=0
 
C...Update ER
        N=N+4
        IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
          CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
          MINT(51)=1
          RETURN
        ENDIF
 
C...Finally, assign colour tags to new partons
        DO 300 JS=1,2
          I1=IMI(JS,MINT(31),1)
          I2=IMI(3-JS,MINT(31),1)
          DO 290 JCS=4,5
            IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
     &           GOTO 290
            IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
            KCS=JCS
            CALL PYCTTR(I1,KCS,I2)
            IF(MINT(51).NE.0) RETURN
  290     CONTINUE
  300   CONTINUE
 
C----------------------------------------------------------------------
C...MODE=2: Decide whether quarks in last scattering were valence,
C...companion, or sea.
      ELSEIF (MODE.EQ.2) THEN
        JS=MINT(30)
        MI=MINT(36)
        PT2=PT2NOW
        KFSBM=ISIGN(1,MINT(10+JS))
        IFL=K(IMI(JS,MI,1),2)
        IMI(JS,MI,2)=0
        IF (IABS(IFL).GE.6) THEN
          IF (IABS(IFL).EQ.6) THEN
            CALL PYERRM(29,'(PYPTMI:) top in initial state!')
          ENDIF
          RETURN
        ENDIF
C...Get PDFs at X(rescaled) and PT2 of the current initiator.
C...(Do not include the parton itself in the X rescaling.)
        X=XMI(JS,MI)
        XRSC=X/(VINT(142+JS)+X)
C...Note: XPSVC = x*pdf.
        MINT(30)=JS
        CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
        SEA=XPSVC(IFL,-1)
        VAL=XPSVC(IFL,0) 
C...Ensure that pdfs are positive definite   
        IF (SEA.LT.0D0) THEN
          CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
          SEA=MAX(0D0,SEA)
        ELSEIF (VAL.LT.0D0) THEN
          CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
          VAL=MAX(0D0,VAL)          
        ENDIF
        CMP=0D0
        DO 310 IVC=1,NVC(JS,IFL)
          CMP=CMP+XPSVC(IFL,IVC)
  310   CONTINUE
 
        NTRY=0
C...Decide (Extra factor x cancels in the dvision).
  320   RVCS=PYR(0)*(SEA+VAL+CMP)
        IVNOW=1
        NTRY=NTRY+1
  330   IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
          IVNOW=0
          IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
          IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
          IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
          IF(KFIVAL(JS,1).EQ.0) THEN
            IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
            IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
            IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
     &           (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
          ELSE
C...Count down valence remaining. Do not count current scattering.
            DO 340 I1=1,NMI(JS)
              IF (I1.EQ.MINT(36)) GOTO 340
              IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
     &             IVNOW=IVNOW-1
  340       CONTINUE
          ENDIF
          IF(IVNOW.EQ.0) GOTO 330
C...Mark valence.
          IMI(JS,MI,2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
          IF(KFIVAL(JS,1).EQ.0) THEN
            IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
              KFIVAL(JS,1)=IFL
              KFIVAL(JS,2)=-IFL
            ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
              KFIVAL(JS,1)=IFL
              IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
              IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
            ENDIF
          ENDIF
 
        ELSEIF (RVCS.LE.VAL+SEA) THEN
C...If sea, add opposite sign companion parton. Store X and I.
          NVC(JS,-IFL)=NVC(JS,-IFL)+1
          XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
C...Set pointer to companion
          IMI(JS,MI,2)=-NVC(JS,-IFL)
 
        ELSE
C...If companion, check whether we've got any in the books
          IF (NVC(JS,IFL).EQ.0) THEN
            CMP=0D0
C...Only report error first time for this event
            IF (NTRY.EQ.1) 
     &           CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
C...Try a few times
            IF (NTRY.LE.10) THEN
              GOTO 320
C... But if it stil fails, abort this event
            ELSE
              MINT(51)=1
              RETURN
            ENDIF
          ENDIF
C...If several possibilities, decide which one
          CMPSUM=VAL+SEA
          ISEL=0
  350     ISEL=ISEL+1
          CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
          IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
C...Find original sea (anti-)quark. Do not consider current scattering.
          IASSOC=0
          DO 360 I1=1,NMI(JS)
            IF (I1.EQ.MINT(36)) GOTO 360
            IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
            IF (-IMI(JS,I1,2).EQ.ISEL) THEN
              IMI(JS,MI,2)=IMI(JS,I1,1)
              IMI(JS,I1,2)=IMI(JS,MI,1)
            ENDIF
  360     CONTINUE
C...Mark companion "out-kicked".
          XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
        ENDIF
 
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
C...Giving the x*f pdf of a companion quark, with its partner at XS,
C...using an approximate gluon density like (1-X)^NPOW/X. The value
C...corresponds to an unrescaled range between 0 and 1-X.
 
      FUNCTION PYFCMP(XC,XS,NPOW)
      IMPLICIT NONE
      DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
      INTEGER NPOW
 
      PYFCMP=0D0
C...Parent gluon momentum fraction
      Y=XC+XS
      IF (Y.GE.1D0) RETURN
C...Common factor (includes factor XC, since PYFCMP=x*f)
      FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
C...Store normalized companion x*f distribution.
      IF (NPOW.LE.0) THEN
        PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
      ELSEIF (NPOW.EQ.1) THEN
        PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
      ELSEIF (NPOW.EQ.2) THEN
        PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
     &       +3D0*XS*(1D0+XS)*LOG(XS)))
      ELSEIF (NPOW.EQ.3) THEN
        PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
     &       +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
      ELSEIF (NPOW.GE.4) THEN
        PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
     &       XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYPCMP: Auxiliary to PYPDFU.
C...Giving the momentum integral of a companion quark, with its
C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
C...The value corresponds to an unrescaled range between 0 and 1-XS.
 
      FUNCTION PYPCMP(XS,NPOW)
      IMPLICIT NONE
      DOUBLE PRECISION XS, PYPCMP
      INTEGER NPOW
      IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
        PYPCMP=0D0
      ELSEIF (NPOW.LE.0) THEN
        PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
        PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
      ELSEIF (NPOW.EQ.1) THEN
        PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
     &       /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
      ELSEIF (NPOW.EQ.2) THEN
        PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
     &       +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
        PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
     &       -3D0*XS*LOG(XS)*(1+XS)))
      ELSEIF (NPOW.EQ.3) THEN
        PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
     &       -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
        PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
     &       +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
      ELSE
        PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
     &       *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
        PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
     &       -6D0*XS*LOG(XS)*(1D0+XS)))
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYUPRE
C...Rearranges contents of the HEPEUP commonblock so that
C...mothers precede daughters and daughters of a decay are
C...listed consecutively.
 
      SUBROUTINE PYUPRE
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...User process event common block.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/
 
C...Local arrays.
      DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
     &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
     &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
 
C...Check whether a rearrangement is required.
      NEED=0
      DO 100 IUP=1,NUP
        IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
  100 CONTINUE
      DO 110 IUP=2,NUP
        IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
  110 CONTINUE
 
      IF(NEED.NE.0) THEN
C...Find the new order that particles should have.
        NEWPOS(0)=0
        NNEW=0
        INEW=-1
  120   INEW=INEW+1
        DO 130 IUP=1,NUP
          IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
            NNEW=NNEW+1
            NEWPOS(NNEW)=IUP
          ENDIF
  130   CONTINUE
        IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
        IF(NNEW.NE.NUP) THEN
          CALL PYERRM(2,
     &    '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
          RETURN
        ENDIF
 
C...Copy old info into temporary storage.
        DO 150 I=1,NUP
          IDUPT(I)=IDUP(I)
          ISTUPT(I)=ISTUP(I)
          MOTUPT(1,I)=MOTHUP(1,I)
          MOTUPT(2,I)=MOTHUP(2,I)
          ICOUPT(1,I)=ICOLUP(1,I)
          ICOUPT(2,I)=ICOLUP(2,I)
          DO 140 J=1,5
            PUPT(J,I)=PUP(J,I)
  140     CONTINUE
          VTIUPT(I)=VTIMUP(I)
          SPIUPT(I)=SPINUP(I)
  150   CONTINUE
 
C...Copy info back into HEPEUP in right order.
        DO 180 I=1,NUP
          IOLD=NEWPOS(I)
          IDUP(I)=IDUPT(IOLD)
          ISTUP(I)=ISTUPT(IOLD)
          MOTHUP(1,I)=0
          MOTHUP(2,I)=0
          DO 160 IMOT=1,I-1
            IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
            IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
  160     CONTINUE
          IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
            MOTHSW=MOTHUP(1,I)
            MOTHUP(1,I)=MOTHUP(2,I)
            MOTHUP(2,I)=MOTHSW
          ENDIF
          ICOLUP(1,I)=ICOUPT(1,IOLD)
          ICOLUP(2,I)=ICOUPT(2,IOLD)
          DO 170 J=1,5
            PUP(J,I)=PUPT(J,IOLD)
  170     CONTINUE
          VTIMUP(I)=VTIUPT(IOLD)
          SPINUP(I)=SPIUPT(IOLD)
  180   CONTINUE
      ENDIF
 
c...If incoming particles are massive recalculate to put them massless.
      IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
        PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
        PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
        PUP(4,1)=0.5D0*PPLUS
        PUP(3,1)=PUP(4,1)
        PUP(5,1)=0D0
        PUP(4,2)=0.5D0*PMINUS
        PUP(3,2)=-PUP(4,2)
        PUP(5,2)=0D0
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYADSH
C...Administers the generation of successive final-state showers
C...in external processes.
 
      SUBROUTINE PYADSH(NFIN)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      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 /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
C...Local array.
      DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
 
C...Set primary vertex.
      DO 100 J=1,5
        V(MINT(83)+5,J)=0D0
        V(MINT(83)+6,J)=0D0
        V(MINT(84)+1,J)=0D0
        V(MINT(84)+2,J)=0D0
  100 CONTINUE
 
C...Isolate systems of particles with the same mother.
      NSYS=0
      IMS=-1
      DO 140 I=MINT(84)+3,NFIN
        IM=K(I,3)
        IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
        IF(IM.NE.IMS) THEN
          NSYS=NSYS+1
          IBEG(NSYS)=I
          IMS=IM
        ENDIF
 
C...Set production vertices.
        IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
     &  THEN
          DO 110 J=1,4
            V(I,J)=0D0
  110     CONTINUE
        ELSE
          DO 120 J=1,4
            V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
  120     CONTINUE
        ENDIF
        IF(MSTP(125).GE.1) THEN
          IDOC=I-MSTP(126)+4
          DO 130 J=1,5
            V(IDOC,J)=V(I,J)
  130     CONTINUE
        ENDIF
  140 CONTINUE
 
C...End loop over systems. Return if no showers to be performed.
      IBEG(NSYS+1)=NFIN+1
      IF(MSTP(71).LE.0) RETURN
 
C...Loop through systems of particles; check that sensible size.
      DO 270 ISYS=1,NSYS
        NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
        IF(MINT(35).LE.2) THEN
          IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
            GOTO 270
          ELSEIF(NSIZ.LE.1) THEN
            CALL PYERRM(2,'(PYADSH:) only one particle in system')
            GOTO 270
          ELSEIF(NSIZ.GT.80) THEN
            CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
            GOTO 270
          ENDIF
        ENDIF
 
C...Save status codes and daughters of showering particles; reset them.
        DO 150 J=1,4
          PSUM(J)=0D0
  150   CONTINUE
        DO 170 II=1,NSIZ
          I=IBEG(ISYS)-1+II
          KSAV(II,1)=K(I,1)
          IF(K(I,1).GT.10) THEN
            K(I,1)=1
            IF(KSAV(II,1).EQ.14) K(I,1)=3
          ENDIF
          IF(KSAV(II,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.1) THEN
            KSAV(II,4)=K(I,4)
            KSAV(II,5)=K(I,5)
            K(I,4)=0
            K(I,5)=0
          ELSE
            KSAV(II,4)=MOD(K(I,4),MSTU(5))
            KSAV(II,5)=MOD(K(I,5),MSTU(5))
            K(I,4)=K(I,4)-KSAV(II,4)
            K(I,5)=K(I,5)-KSAV(II,5)
          ENDIF
          DO 160 J=1,4
            PSUM(J)=PSUM(J)+P(I,J)
  160     CONTINUE
  170   CONTINUE
 
C...Perform shower.
        QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
     &  PSUM(3)**2))
        IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
        NSAV=N
        IF(MINT(35).LE.2) THEN
          IF(NSIZ.EQ.2) THEN
            CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
          ELSE
            CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
          ENDIF
 
C...For external processes, first call, also ISR partons radiate.
C...Can use existing PYPART list, removing partons that radiate later.
        ELSEIF(ISYS.EQ.1) THEN
          NPARTN=0
          DO 175 II=1,NPART
            IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
              NPARTN=NPARTN+1
              IPART(NPARTN)=IPART(II)
              PTPART(NPARTN)=PTPART(II)
            ENDIF
 175      CONTINUE
          NPART=NPARTN
          CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
        ELSE
C...For subsequent calls use the systems excluded above.
          NPART=NSIZ
          NPARTD=0
          DO 180 II=1,NSIZ
            I=IBEG(ISYS)-1+II
            IPART(II)=I
            PTPART(II)=0.5D0*QMAX
  180     CONTINUE
          CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
        ENDIF
 
C...Look up showered copies of original showering particles.
        DO 260 II=1,NSIZ
          I=IBEG(ISYS)-1+II
          IMV=I
C...Particles without daughters need not be studied.
          IF(KSAV(II,1).LE.10) GOTO 260
          IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.11) THEN
  190       IMV=MOD(K(IMV,4),MSTU(5))
            IF(K(IMV,1).EQ.11) GOTO 190
          ELSE
            KDA1=MOD(K(I,4),MSTU(5))
            IF(KDA1.GT.0) THEN
              IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
            ENDIF
            KDA2=MOD(K(I,5),MSTU(5))
            IF(KDA2.GT.0) THEN
              IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
            ENDIF
            DO 200 I3=I+1,N
              IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
     &        THEN
                IMV=I3
                KDA1=MOD(K(I3,4),MSTU(5))
                IF(KDA1.GT.0) THEN
                  IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
                ENDIF
                KDA2=MOD(K(I3,5),MSTU(5))
                IF(KDA2.GT.0) THEN
                  IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
                ENDIF
              ENDIF
  200       CONTINUE
          ENDIF
 
C...Restore daughter info of original partons to showered copies.
          IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
          IF(KSAV(II,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.1) THEN
            K(IMV,4)=KSAV(II,4)
            K(IMV,5)=KSAV(II,5)
          ELSE
            K(IMV,4)=K(IMV,4)+KSAV(II,4)
            K(IMV,5)=K(IMV,5)+KSAV(II,5)
          ENDIF
 
C...Reset mother info of existing daughters to showered copies.
          DO 210 I3=IBEG(ISYS+1),NFIN
            IF(K(I3,3).EQ.I) K(I3,3)=IMV
            IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
              IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
              IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
            ENDIF
  210     CONTINUE
 
C...Boost all original daughters to new frame of showered copy.
C...Also update their colour tags.
          IF(IMV.NE.I) THEN
            DO 220 J=1,3
              BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
  220       CONTINUE
            FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
            DO 230 J=1,3
              BETA(J)=FAC*BETA(J)
  230       CONTINUE
            DO 250 I3=IBEG(ISYS+1),NFIN
              IMO=I3
  240         IMO=K(IMO,3)
              IF(MSTP(128).LE.0) THEN
                IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
                IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
     &          THEN
                  CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
                  IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
                  IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
                ENDIF
              ELSE
                IF(IMO.EQ.IMV) THEN
                  CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
                  IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
                  IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
                ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
                  GOTO 240
                ENDIF
              ENDIF
  250       CONTINUE
          ENDIF
  260   CONTINUE
 
C...End of loop over showering systems
  270 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYVETO
C...Interface to UPVETO, which allows user to veto event generation
C...on the parton level, after parton showers but before multiple
C...interactions, beam remnants and hadronization is added.
 
      SUBROUTINE PYVETO(IVETO)
 
C...All real arithmetic in double precision.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
C...Three Pythia functions return integers, so need declaring.
      INTEGER PYK,PYCHGE,PYCOMP
 
C...PYTHIA commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYJETS/,/PYPARS/,/PYINT1/
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...Local array.
      DIMENSION IRESO(100)
 
C...Define longitudinal boost from initiator rest frame to cm frame.
      GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
      GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))

C...Presentation is different if using pT-ordered shower
      IF(MINT(35).EQ.3) THEN
        GAMMA=1D0
        GABEZ=0D0
      ENDIF

C... Reset counters.
      NEVHEP=0
      NHEP=0
      NRESO=0
      
C...Oth pass: identify beam and incoming partons
      DO 140 I=MINT(83)+1,MINT(83)+6
        ISTORE=0
        IF(K(I,2).EQ.94) THEN

        ELSE
          NRESO=NRESO+1
          IRESO(NRESO)=I
          IMOTH=K(I,3)
        ENDIF
 140  CONTINUE

C...First pass: identify final locations of resonances
C...and of their daughters before showering.
      DO 150 I=MINT(84)+3,N
        ISTORE=0
        IMOTH=0
 
C...Skip shower CM frame documentation lines.
        IF(K(I,2).EQ.94) THEN
 
C...  Store a new intermediate product, when mother in documentation.
        ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
     &  K(I,3).LE.MINT(84)) THEN
          ISTORE=1
          NHEP=NHEP+1
          II=NHEP
          NRESO=NRESO+1
          IRESO(NRESO)=I
          IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
 
C...  Store a new intermediate product, when mother in main section.
        ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
     &  K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
          ISTORE=1
          NHEP=NHEP+1
          II=NHEP
          NRESO=NRESO+1
          IRESO(NRESO)=I
          IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
        ENDIF
  
        IF(ISTORE.EQ.1) THEN
C...Copy parton info, boosting momenta along z axis to cm frame.
          ISTHEP(II)=2
          IDHEP(II)=K(I,2)
          PHEP(1,II)=P(I,1)
          PHEP(2,II)=P(I,2)
          PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
          PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
          PHEP(5,II)=P(I,5)
C...Store one mother. Rest of history and vertex info zeroed.
          JMOHEP(1,II)=IMOTH
          JMOHEP(2,II)=0
          JDAHEP(1,II)=0
          JDAHEP(2,II)=0
          VHEP(1,II)=0D0
          VHEP(2,II)=0D0
          VHEP(3,II)=0D0
          VHEP(4,II)=0D0
        ENDIF
 150  CONTINUE

C...Second pass: identify current set of "final" partons.
      DO 200 I=MINT(84)+3,N
        ISTORE=0
        IMOTH=0
 
C...Store a final parton.
        IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
          ISTORE=1
          NHEP=NHEP+1
          II=NHEP
C..Trace it back through shower, to check if from documented particle.
          IHIST=I
          ISAVE=IHIST
  160     CONTINUE
          IF(IHIST.GT.MINT(84)) THEN
            IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
            DO 170 IRI=1,NRESO
              IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
  170       CONTINUE
            ISAVE=IHIST
            IHIST=K(IHIST,3)
            IF(IMOTH.EQ.0) GOTO 160
            IMOTH=MAX(0,IMOTH-6)
          ELSEIF(IHIST.LE.4) THEN
            IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
              ISTORE=0
              NHEP=NHEP-1
            ELSE
              IMOTH=0
            ENDIF
          ENDIF
        ENDIF
 
        IF(ISTORE.EQ.1) THEN
C...Copy parton info, boosting momenta along z axis to cm frame.
          ISTHEP(II)=1
          IDHEP(II)=K(I,2)
          PHEP(1,II)=P(I,1)
          PHEP(2,II)=P(I,2)
          PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
          PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
          PHEP(5,II)=P(I,5)
C...Store one mother. Rest of history and vertex info zeroed.
          JMOHEP(1,II)=IMOTH
          JMOHEP(2,II)=0
          JDAHEP(1,II)=0
          JDAHEP(2,II)=0
          VHEP(1,II)=0D0
          VHEP(2,II)=0D0
          VHEP(3,II)=0D0
          VHEP(4,II)=0D0
        ENDIF
  200 CONTINUE
C...Call user-written routine to decide whether to keep events.
      CALL UPVETO(IVETO)
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      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(8000,2),BRAT(8000),KFDP(8000,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/PYPUED/IUED(0:99),RUED(0:99)
      SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
     &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
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:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
     &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
      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...Boost and rotate to rest frame of incoming partons, 
C...to get proper amount of smearing of decay angles.
      IBST=0
      IF(IRES.EQ.0) THEN
        IBST=1
        IIN1=MINT(84)+1
        IIN2=MINT(84)+2
C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons 
C...(101,102) are off shell and can have inconsistent momenta, resulting 
C...in boosts larger than unity. However, the corresponding docu partons 
C...(5,6) are kept on shell, and have consistent momenta that can be used 
C...to derive this boost instead. Ultimately, should change the way the new 
C...shower stores intermediate partons, but just using partons (5,6) for now 
C...does define the boost and furnishes a quick and much needed solution.
        IF (MINT(35).EQ.3) THEN
          IIN1=MINT(83)+5
          IIN2=MINT(83)+6
        ENDIF
        ETOTIN=P(IIN1,4)+P(IIN2,4)
        BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
        BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
        BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
        CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
        PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
        CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
        THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
        CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
      ENDIF
 
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.
      IHDEC=0
      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
        IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
     &  IHDEC=1
        IF(IHDEC.EQ.1) ISUB=3
        IREF(1,1)=IRES
        IREF(1,4)=K(IRES,3)
        IRESTM=IRES
        IF(IREF(1,4).GT.MINT(84)) THEN
  110     ITMPMO=IREF(1,4)
          IF(K(ITMPMO,2).EQ.94) THEN
            IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
            IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
          ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
            IRESTM=ITMPMO
C...Explicitly check that reference particle exists, otherwise stop recursion
            IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
              IREF(1,4)=K(ITMPMO,3)
              GOTO 110
            ENDIF
          ENDIF
        ENDIF
        IF(IREF(1,4).GT.MINT(84)) THEN
          EMATCH=1D10
          IREF14=IREF(1,4)
          DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
            IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
     &      EMATCH) THEN
              IREF(1,4)=II
              EMATCH=ABS(P(II,4)-P(IREF14,4))
            ENDIF
  120     CONTINUE
        ENDIF
        JTMAX=1
      ENDIF
 
C...Check if initial resonance has been moved (in resonance + jet).
      DO 140 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
              KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
              KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
              IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
                IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
              ENDIF
              IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
                IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
              ENDIF
              DO 130 I=IREF(1,JT)+1,N
                IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
     &          I.EQ.KDA2)) THEN
                  IREF(1,JT)=I
                  KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
                  KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
                  IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
                    IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
                  ENDIF
                  IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
                    IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
                  ENDIF
                ENDIF
  130         CONTINUE
            ELSE
              KDA=MOD(K(IREF(1,JT),4),MSTU(5))
              IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
            ENDIF
          ENDIF
        ENDIF
  140 CONTINUE
 
C...Set decay vertex for initial resonances
      DO 160 JT=1,JTMAX
        DO 150 I=1,4
          V(IREF(1,JT),I)=0D0
  150   CONTINUE
  160 CONTINUE
 
C...Loop over decay history.
      NP=1
      IP=0
  170 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...Check for Higgs which appears as decay product of user-process.
      IF(ISUB.EQ.0) THEN
        IHDEC=0
        IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
     &  .EQ.36) IHDEC=1
        IF(IHDEC.EQ.1) ISUB=3
      ENDIF
 
C...Start treatment of one, two or three resonances in parallel.
  180 N=NSAV
      DO 340 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
        ITJUNC(JT)=0
 
C...Check whether particle can/is allowed to decay.
        IF(ID.EQ.0) GOTO 330
        KFA=IABS(K(ID,2))
        KCA=PYCOMP(KFA)
        IF(MWID(KCA).EQ.0) GOTO 330
        IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
        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 190 J=1,4
          VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
  190   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 330
        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 330
        RKFL=WDTE0S*PYR(0)
        IDL=0
  200   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 200
 
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))
        KCQ3(JT)=0
        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 220 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 220
            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 210 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
 210        CONTINUE
C   MRENNA--
          ELSEIF(KFLW.EQ.6) THEN
            PMMN(I)=PMAS(24,1)+PMAS(5,1)
          ENDIF
C...UED: select a graviton mass from continuous distribution
C...(stored in PMAS(39,1) so no value returned)
          IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39) 
     &         CALL PYGRAM(1)
 220    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
            GOTO 720
          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
            GOTO 720
          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
  230       LOOP=LOOP+1
            P(N+IWID3,5)=PYMASS(KFLW3)
            IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
            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) GOTO 720
        ENDIF
 
C...Begin fill decay products, with colour flow for coloured objects.
        MSTU10=MSTU(10)
        MSTU(10)=1
        MSTU(19)=1
 
C...Three-body decays 
        IF(KFL3(JT).NE.0) THEN
          DO 250 I=N+1,N+3
            DO 240 J=1,5
              K(I,J)=0
              V(I,J)=0D0
  240       CONTINUE
            MCT(I,1)=0
            MCT(I,2)=0
  250     CONTINUE
          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)
          IDIN=ID

C...Generate kinematics (default is flat)
          CALL PYTBDY(IDIN)

C...Set generic colour flows whenever unambiguous,
C...(independently of the order of the decay products)
C...Sum up total colour content
          NANT=0
          NTRI=0
          NOCT=0
          KCQ(0)=KCQM(JT)
          KCQ(1)=KCQ1(JT)
          KCQ(2)=KCQ2(JT)
          KCQ(3)=KCQ3(JT)
          DO 255 J=0,3
            IF (KCQ(J).EQ.-1) THEN
              NANT=NANT+1
              IANT(NANT)=N+J
            ELSEIF (KCQ(J).EQ.1) THEN
              NTRI=NTRI+1              
              ITRI(NTRI)=N+J
            ELSEIF (KCQ(J).EQ.2) THEN 
              NOCT=NOCT+1
              IOCT(NOCT)=N+J
            ENDIF
 255      CONTINUE
          
C...Set color flow for generic 1 -> N processes (N arbitrary)
          IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
C...All singlets: do nothing
            
          ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
C...Two octets, zero triplets, n singlets:
            IF (KCQ(0).EQ.2) THEN
C...8 -> 8 + n(1) 
              K(ID,4)=K(ID,4)+IOCT(2)
              K(ID,5)=K(ID,5)+IOCT(2)
              K(IOCT(2),1)=3
              K(IOCT(2),4)=MSTU(5)*ID
              K(IOCT(2),5)=MSTU(5)*ID
              MCT(IOCT(2),1)=MCT(ID,1)
              MCT(IOCT(2),2)=MCT(ID,2)
            ELSE
C...1 -> 8 + 8 + n(1)
              K(IOCT(1),1)=3
              K(IOCT(1),4)=MSTU(5)*IOCT(2)
              K(IOCT(1),5)=MSTU(5)*IOCT(2)
              K(IOCT(2),1)=3
              K(IOCT(2),4)=MSTU(5)*IOCT(1)
              K(IOCT(2),5)=MSTU(5)*IOCT(1)
              NCT=NCT+1
              MCT(IOCT(1),1)=NCT
              MCT(IOCT(2),2)=NCT
              NCT=NCT+1
              MCT(IOCT(2),1)=NCT
              MCT(IOCT(1),2)=NCT
            ENDIF
            
          ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
C...Two triplets, zero octets, n singlets.            
            IF (KCQ(0).EQ.1) THEN
C...3 -> 3 + n(1)
              K(ID,4)=K(ID,4)+ITRI(2)
              K(ITRI(2),1)=3
              K(ITRI(2),4)=MSTU(5)*ID
              MCT(ITRI(2),1)=MCT(ID,1)
            ELSEIF (KCQ(0).EQ.-1) THEN
C...3bar -> 3bar + n(1)              
              K(ID,5)=K(ID,5)+IANT(2)
              K(IANT(2),1)=3
              K(IANT(2),5)=MSTU(5)*ID
              MCT(IANT(2),2)=MCT(ID,2)
            ELSE
C...1 -> 3 + 3bar + n(1)
              K(ITRI(1),1)=3
              K(ITRI(1),4)=MSTU(5)*IANT(1)
              K(IANT(1),1)=3
              K(IANT(1),5)=MSTU(5)*ITRI(1)
              NCT=NCT+1
              MCT(ITRI(1),1)=NCT
              MCT(IANT(1),2)=NCT
            ENDIF
            
          ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
C...Two triplets, one octet, n singlets.            
            IF (KCQ(0).EQ.2) THEN
C...8 -> 3 + 3bar + n(1)
              K(ID,4)=K(ID,4)+ITRI(1)
              K(ID,5)=K(ID,5)+IANT(1)
              K(ITRI(1),1)=3
              K(ITRI(1),4)=MSTU(5)*ID
              K(IANT(1),1)=3
              K(IANT(1),5)=MSTU(5)*ID
              MCT(ITRI(1),1)=MCT(ID,1)
              MCT(IANT(1),2)=MCT(ID,2)
            ELSEIF (KCQ(0).EQ.1) THEN
C...3 -> 8 + 3 + n(1)
              K(ID,4)=K(ID,4)+IOCT(1)
              K(IOCT(1),1)=3
              K(IOCT(1),4)=MSTU(5)*ID
              K(IOCT(1),5)=MSTU(5)*ITRI(2)
              K(ITRI(2),1)=3
              K(ITRI(2),4)=MSTU(5)*IOCT(1)
              MCT(IOCT(1),1)=MCT(ID,1)
              NCT=NCT+1
              MCT(IOCT(1),2)=NCT
              MCT(ITRI(2),1)=NCT
            ELSEIF (KCQ(0).EQ.-1) THEN
C...3bar -> 8 + 3bar + n(1)
              K(ID,5)=K(ID,5)+IOCT(1)
              K(IOCT(1),1)=3
              K(IOCT(1),5)=MSTU(5)*ID
              K(IOCT(1),4)=MSTU(5)*IANT(2)
              K(IANT(2),1)=3
              K(IANT(2),5)=MSTU(5)*IOCT(1)
              MCT(IOCT(1),2)=MCT(ID,2)
              NCT=NCT+1
              MCT(IOCT(1),1)=NCT
              MCT(IANT(2),2)=NCT
            ELSE
C...1 -> 3 + 3bar + 8 + n(1)
              K(ITRI(1),1)=3
              K(ITRI(1),4)=MSTU(5)*IOCT(1)
              K(IOCT(1),1)=3
              K(IOCT(1),5)=MSTU(5)*ITRI(1)
              K(IOCT(1),4)=MSTU(5)*IANT(1)
              K(IANT(1),1)=3
              K(IANT(1),5)=MSTU(5)*IOCT(1)
              NCT=NCT+1
              MCT(ITRI(1),1)=NCT
              MCT(IOCT(1),2)=NCT
              NCT=NCT+1
              MCT(IOCT(1),1)=NCT
              MCT(IANT(1),2)=NCT
            ENDIF
CPS-- End of generic cases 
C...(could three octets also be handled?)
C...(could (some of) the RPV cases be made generic as well?)

C...Special cases (= old treatment)
C...Set colour flow for t -> W + b + Z.
          ELSEIF(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)
C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
          ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
     &          .AND.KFL3(JT).NE.0) THEN
            KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
C...3-body decays of squarks to colour singlets plus one quark
            IF (KQSUMA.EQ.1) THEN
C...Find quark
              IQ=0
              IF (KCQ1(JT).NE.0) IQ=1
              IF (KCQ2(JT).NE.0) IQ=2
              IF (KCQ3(JT).NE.0) IQ=3
              ISID=4
              IF (K(N+IQ,2).LT.0) ISID=5
              K(N+IQ,1)=3
              K(ID,ISID)=K(ID,ISID)+(N+IQ)
              K(N+IQ,ISID)=MSTU(5)*ID
            ENDIF
C...PS--
          ELSEIF(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)
          ELSEIF(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
CMRENNA--
 
          ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
     &    IABS(KCQ2(JT)).EQ.1) 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
           
          NSAV=N
          
C...Set colour flow in three-body decays with baryon number violation.
C...Neutralino and chargino decays first.
          KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
          IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
            ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
            K(N+4,4)=ITJUNC(JT)*MSTU(5)
C...Insert junction to keep track of colours.
            IF(KCQ1(JT).NE.0) K(N+1,1)=3
            IF(KCQ2(JT).NE.0) K(N+2,1)=3
            IF(KCQ3(JT).NE.0) K(N+3,1)=3
C...Set special junction codes:
            K(N+4,1)=42
            K(N+4,2)=88
 
C...Order decay products by invariant mass. (will be used in PYSTRF).
            PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)-
     &      P(N+1,3)*P(N+2,3)
            PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)-
     &      P(N+1,3)*P(N+3,3)
            PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)-
     &      P(N+2,3)*P(N+3,3)
            IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
              K(N+4,4)=N+3+K(N+4,4)
              K(N+4,5)=N+1+MSTU(5)*(N+2)
            ELSEIF(PM13.LT.PM23) THEN
              K(N+4,4)=N+2+K(N+4,4)
              K(N+4,5)=N+1+MSTU(5)*(N+3)
            ELSE
              K(N+4,4)=N+1+K(N+4,4)
              K(N+4,5)=N+2+MSTU(5)*(N+3)
            ENDIF
            DO 260 J=1,5
              P(N+4,J)=0D0
              V(N+4,J)=0D0
  260       CONTINUE
C...Connect daughters to junction.
            DO 270 II=N+1,N+3
              K(II,4)=0
              K(II,5)=0
              K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
  270       CONTINUE
C...Particle counter should be stepped up one extra for junction.
            N=N+1
 
C...Gluino decays.
          ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
            ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
            K(N+4,4)=ITJUNC(JT)*MSTU(5)
C...Insert junction to keep track of colours.
            IF(KCQ1(JT).NE.0) K(N+1,1)=3
            IF(KCQ2(JT).NE.0) K(N+2,1)=3
            IF(KCQ3(JT).NE.0) K(N+3,1)=3
            K(N+4,1)=42
            K(N+4,2)=88
            DO 280 J=1,5
              P(N+4,J)=0D0
              V(N+4,J)=0D0
  280       CONTINUE
            CTMSUM=0D0
            DO 290 II=N+1,N+3
              K(II,4)=0
              K(II,5)=0
C...Start by connecting all daughters to junction.
              K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
C...Only consider colour topologies with off shell resonances.
              RMQ1=PMAS(PYCOMP(K(II,2)),1)
              RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
              RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
              IF (RMGLU-RMQ1.LT.RMRES) THEN
C...Calculate propagators for each colour topology.
                RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
     &               *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
                CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
              ELSE
                CTM2(II-N)=0D0
              ENDIF
              CTMSUM=CTMSUM+CTM2(II-N)
  290       CONTINUE
            CTMSUM=PYR(0)*CTMSUM
C...Select colour topology J, with most off shell least likely.
            J=0
  300       J=J+1
            CTMSUM=CTMSUM-CTM2(J)
            IF (CTMSUM.GT.0D0) GOTO 300
C...The lucky winner gets its colour (anti-colour) directly from gluino.
            K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
            K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
C...The other gluino colour is connected to junction
            K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
     &      MSTU(5)
            K(N+4,4)=K(N+4,4)+ID
C...Lastly, connect junction to remaining daughters.
            K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
C...Particle counter should be stepped up one extra for junction.
            N=N+1
          ENDIF
 
C...Update particle counter.
          N=N+3

C...2) Everything else two-body decay.
        ELSE
          CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
          MCT(N-1,1)=0
          MCT(N-1,2)=0
          MCT(N,1)=0
          MCT(N,2)=0
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
 
C...Insert junction
          IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
            N=N+1
C...~q* mother: type 3 junction. ~q mother: type 4.
            ITJUNC(JT)=(7+KCQM(JT))/2
C...Specify junction KF and set colour flow from junction
            K(N,1)=42
            K(N,2)=88
            K(N,3)=ID
C...Junction type encoded together with mother:
            K(N,4)=ID+ITJUNC(JT)*MSTU(5)
            K(N,5)=N-1+MSTU(5)*(N-2)
C...Zero P and V for junction (V filled later)
            DO 310 J=1,5
              P(N,J)=0D0
              V(N,J)=0D0
  310       CONTINUE
C...Set colour flow from mother to junction
            K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
C...Set colour flow from daughters to junction
            DO 320 II=N-2,N-1
              K(II,4) = 0
              K(II,5) = 0
C...(Anti-)colour mother is junction.
              K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
  320       CONTINUE
          ENDIF
        ENDIF
 
C...End loop over resonances for daughter flavour and mass selection.
        MSTU(10)=MSTU10
  330   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.MDCY(KCA,1).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
          GOTO 720
        ENDIF
  340 CONTINUE
 
C...Check for allowed combinations. Skip if no decays.
      IF(JTMAX.EQ.1) THEN
        IF(KDCY(1).EQ.0) GOTO 710
      ELSEIF(JTMAX.EQ.2) THEN
        IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
        IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
        IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
      ELSEIF(JTMAX.EQ.3) THEN
        IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
        IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
        IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
        IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
        IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
        IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
        IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
      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
          GOTO 720
        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 360 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 350 J=1,5
              P(I1,J)=P(I,J)
  350       CONTINUE
          ENDIF
  360   CONTINUE
 
C...Generate parton shower.
        IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
          CALL PYSHOW(N-1,N,P(ID,5))
        ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
          NPART=2
          IPART(1)=N-1
          IPART(2)=N
          PTPART(1)=0.5D0*P(ID,5)
          PTPART(2)=PTPART(1)
          NCT=NCT+1
          IF(K(N-1,2).GT.0) THEN
            MCT(N-1,1)=NCT
            MCT(N,2)=NCT
          ELSE
            MCT(N-1,2)=NCT
            MCT(N,1)=NCT
          ENDIF
          CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
        ENDIF
 
C... End special case for Z0: skip ahead.
        MSTU(111)=MST111
        PARU(112)=PAR112
        GOTO 700
      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 370 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
  370   CONTINUE
 
C...Find charge, isospin, left- and righthanded couplings.
        DO 390 I=IMIN,IMAX
          DO 380 J=1,4
            COUP(I,J)=0D0
  380     CONTINUE
          KFA=IABS(K(ILIN(I),2))
          IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
          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)
  390   CONTINUE
 
C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
        IF(ISUB.EQ.22) THEN
          DO 420 I=3,5,2
            I1=IORD
            IF(I.EQ.5) I1=3-IORD
            DO 410 J1=1,2
              DO 400 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
  400         CONTINUE
  410       CONTINUE
  420     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 180
        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).
  430 DO 440 JT=1,JTMAX
        IF(KDCY(JT).EQ.0) GOTO 440
        IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.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
  440 CONTINUE
 
      IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
C...Construct massless four-vectors.
        DO 460 I=N+1,N+4
          K(I,1)=1
          DO 450 J=1,5
            P(I,J)=0D0
            V(I,J)=0D0
  450     CONTINUE
  460   CONTINUE
        DO 470 JT=1,JTMAX
          IF(KDCY(JT).EQ.0) GOTO 470
          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))
  470   CONTINUE
 
C...Store incoming and outgoing momenta, with random rotation to
C...avoid accidental zeroes in HA expressions.
        IF(ISUB.NE.0) THEN
          DO 490 I=IMIN,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 480 J=1,3
              P(N+4+I,J)=P(ILIN(I),J)
  480       CONTINUE
  490     CONTINUE
  500     THERR=ACOS(2D0*PYR(0)-1D0)
          PHIRR=PARU(2)*PYR(0)
          CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
          DO 520 I=IMIN,IMAX
            IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
     &      P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
            DO 510 J=1,4
              PK(I,J)=P(N+4+I,J)
  510       CONTINUE
  520     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 540 I1=IMIN,IMAX-1
            DO 530 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)
  530       CONTINUE
  540     CONTINUE
        ENDIF
 
C...Calculate four-products.
        IF(ISUB.NE.0) THEN
          DO 560 I=1,2
            DO 550 J=1,4
              PK(I,J)=-PK(I,J)
  550       CONTINUE
  560     CONTINUE
          DO 580 I1=IMIN,IMAX-1
            DO 570 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)
  570       CONTINUE
  580     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/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
C...CP-odd case added by Kari Ertresvag Myklevoll.
C...Now also with mixed Higgs CP-states
        ETA=PARP(25)
        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))
        KFT=IABS(K(IREF(IP,2),2))
        
        IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
     &  MSTP(25).GE.3) THEN
C...For mixed CP states need epsilon product.
          P10=PK(3,4)
          P20=PK(4,4)
          P30=PK(5,4)
          P40=PK(6,4)
          P11=PK(3,1)
          P21=PK(4,1)
          P31=PK(5,1)
          P41=PK(6,1)
          P12=PK(3,2)
          P22=PK(4,2)
          P32=PK(5,2)
          P42=PK(6,2)
          P13=PK(3,3)
          P23=PK(4,3)
          P33=PK(5,3)
          P43=PK(6,3)
          EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
     &      P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
     &      P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
     &      P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
     &      P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
     &      P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
     &      P22*P30*P41+P13*P22*P31*P40
C...For mixed CP states need gauge boson masses.
          XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
     &      (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
          XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
     &      (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
          XMV=PMAS(KFA,1)
        ENDIF
 
C...Z decay
        IF(KFA.EQ.23.AND.KFA.EQ.KFT) 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))
          IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
     &      THEN
C...CP-even decay
            WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
     &        8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
          ELSEIF(MSTP(25).LE.2) THEN
C...CP-odd decay
            WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
     &        -2*PKK(3,4)*PKK(5,6)
     &        -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
     &        (PKK(3,4)*PKK(5,6))
     &        +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
     &        (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
          ELSE
C...Mixed CP states.
            WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
     &        +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
     &        -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
     &        -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
     &        +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
     &        -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
     &        +PKK(3,4)*PKK(5,6)
     &        *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
     &        +VA12AS*PKK(3,4)*PKK(5,6)
     &        *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
     &        *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
     &        /(1D0 +2D0*ETA*XMA*XMB/XMV**2
     &          +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
          ENDIF
 
C...W decay
        ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
          IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
     &      THEN
C...CP-even decay
            WT=16D0*PKK(3,5)*PKK(4,6)
          ELSEIF(MSTP(25).LE.2) THEN
C...CP-odd decay
            WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
     &        -2*PKK(3,4)*PKK(5,6)
     &        -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
     &        (PKK(3,4)*PKK(5,6))
     &        +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
     &        (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
          ELSE
C...Mixed CP states.
            WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
     &        -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
     &        +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
     &        -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
     &        +PKK(3,4)*PKK(5,6)
     &        *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
     &        +PKK(3,4)*PKK(5,6)
     &        *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
     &        *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
     &        /(1D0 +2D0*ETA*XMA*XMB/XMV**2
     &          +(2D0*ETA*XMA*XMB/XMV**2)**2)
          ENDIF
 
C...No angular correlations in other Higgs decays.
        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.
        RM3=PMAS(IABS(KFL1(1)),1)**2/SH
        RM4=PMAS(IABS(KFL2(1)),1)**2/SH
        BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
        WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**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.
        POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
        POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
        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))
        IF(MSTP(50).LE.0) THEN
          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)))
        ELSE
          WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
          WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
     &    CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
     &    POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
        ENDIF
 
      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
C...Special case: if only branching ratios known then isotropic decay.
        IF(MWID(32).EQ.2) THEN
          WT=1D0
          WTMAX=1D0
        ELSEIF(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
C...Special case: if only branching ratios known then isotropic decay.
        IF(MWID(34).EQ.2) THEN
          WT=1D0
          WTMAX=1D0
        ELSEIF(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_tc0 -> W+ W-,
C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
          WT=1D0-CTHE(1)**2
          WTMAX=1D0
        ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar -> rho_tc0 -> 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_tc produced in rho_tc 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_tc+ -> W+ Z0,
C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
          WT=1D0-CTHE(1)**2
          WTMAX=1D0
        ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
          CTHESG=CTHE(1)*ISIGN(1,MINT(15))
          WT=(1D0+CTHESG)**2
          WTMAX=4D0
        ELSE
C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ 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_tc0 ->
C...gamma pi_tc0 or Z0 pi_tc0.
          WT=1D0+CTHE(1)**2
          WTMAX=2D0
        ELSEIF(IP.EQ.1) THEN
C...Angular weight for f + fbar -> omega_tc0 -> 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_tc produced in omega_tc decay.
          WT=1D0
          WTMAX=1D0
        ENDIF
 
      ELSEIF(ISUB.EQ.353) THEN
C...Angular weight for Z_R0 -> 2 quarks/leptons.
        EI=KCHG(IABS(MINT(15)),1)/3D0
        AI=SIGN(1D0,EI+0.1D0)
        VI=AI-4D0*EI*XWV
        EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
        AF=SIGN(1D0,EF+0.1D0)
        VF=AF-4D0*EF*XWV
        RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
        WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
        WT2=RMF*(VI**2+AI**2)*VF**2
        WT3=SQRT(1D0-RMF)*4D0*VI*AI*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.354) THEN
C...Angular weight for W_R+/- -> 2 quarks/leptons.
        RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
        RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
        BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
        WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
        WTMAX=4D0
 
      ELSEIF(ISUB.EQ.391) THEN
C...Angular weight for f + fbar -> G* -> f + fbar
        IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
          WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
          WTMAX=2D0
C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
C...implemented by M.-C. Lemaire
        ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
     &  IABS(KFL1(1)).EQ.22)) THEN
          WT=1D0-CTHE(1)**4
          WTMAX=1D0
C...Other G* decays not yet implemented angular distributions.
        ELSE
          WT=1D0
          WTMAX=1D0
        ENDIF
 
      ELSEIF(ISUB.EQ.392) THEN
C...Angular weight for g + g -> G* -> f + fbar
        IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
          WT=1D0-CTHE(1)**4
          WTMAX=1D0
C...Angular weight for g + g -> G* -> gamma +gamma or g + g
C...implemented by M.-C. Lemaire
        ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
     &  IABS(KFL1(1)).EQ.22)) THEN
         WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
          WTMAX=8D0
C...Other G* decays not yet implemented angular distributions.
        ELSE
          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 430
 
C...Construct massive four-vectors using angles chosen.
  590 DO 690 JT=1,JTMAX
        IF(KDCY(JT).EQ.0) GOTO 690
        ID=IREF(IP,JT)
        DO 600 J=1,5
          DPMO(J)=P(ID,J)
  600   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 610 J=1,4
          VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
  610   CONTINUE
C...Fill in position of decay vertex.
        DO 630 I=NSD(JT)+1,N0
          DO 620 J=1,4
            V(I,J)=VDCY(J)
  620     CONTINUE
          V(I,5)=0D0
 
  630   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
C...If 3-body or 2-body with junction:
          IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
C...If 3-body with junction:
          IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
        ENDIF
 
C...Add documentation lines.
        ISUBRG=MAX(1,MIN(500,MINT(1)))
        IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
          IDOC=MINT(83)+MINT(4)
CMRENNA+++
          IHI=NSD(JT)+2
          IF(KFL3(JT).NE.0) IHI=IHI+1
          DO 650 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 640 J=1,5
                P(I1,J)=P(I,J)
  640         CONTINUE
            ENDIF
  650     CONTINUE
        ELSE
          K(NSD(JT)+1,3)=ID
          K(NSD(JT)+2,3)=ID
C...If 3-body or 2-body with junction:
          IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
C...If 3-body with junction:
          IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
        ENDIF
 
C...Do showering of two or three objects.
        NSHBEF=N
        IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
          IF(KFL3(JT).EQ.0) THEN
            CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
          ELSE
            CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
          ENDIF
 
c...For pT-ordered shower need set up first, especially colour tags.
C...(Need to set up colour tags even if MSTP(71) = 0)
        ELSEIF(MINT(35).GE.2) THEN
          NPART=2
          IF(KFL3(JT).NE.0) NPART=3
          IPART(1)=NSD(JT)+1
          IPART(2)=NSD(JT)+2
          IPART(3)=NSD(JT)+3
          PTPART(1)=0.5D0*P(ID,5)
          PTPART(2)=PTPART(1)
          PTPART(3)=PTPART(1)
          IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
            MOTHER=K(NSD(JT)+1,4)/MSTU(5)
            IF(MOTHER.LE.NSD(JT)) THEN
              MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
            ELSE
              NCT=NCT+1
              MCT(NSD(JT)+1,1)=NCT
              MCT(MOTHER,2)=NCT
            ENDIF
          ENDIF
          IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
            MOTHER=K(NSD(JT)+1,5)/MSTU(5)
            IF(MOTHER.LE.NSD(JT)) THEN
              MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
            ELSE
              NCT=NCT+1
              MCT(NSD(JT)+1,2)=NCT
              MCT(MOTHER,1)=NCT
            ENDIF
          ENDIF
          IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
     &    KCQ2(JT).EQ.2)) THEN
            MOTHER=K(NSD(JT)+2,4)/MSTU(5)
            IF(MOTHER.LE.NSD(JT)) THEN
              MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
            ELSE
              NCT=NCT+1
              MCT(NSD(JT)+2,1)=NCT
              MCT(MOTHER,2)=NCT
            ENDIF
          ENDIF
          IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
     &    KCQ2(JT).EQ.2)) THEN
            MOTHER=K(NSD(JT)+2,5)/MSTU(5)
            IF(MOTHER.LE.NSD(JT)) THEN
              MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
            ELSE
              NCT=NCT+1
              MCT(NSD(JT)+2,2)=NCT
              MCT(MOTHER,1)=NCT
            ENDIF
          ENDIF
          IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
     &    (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
            MOTHER=K(NSD(JT)+3,4)/MSTU(5)
            MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
          ENDIF
          IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
     &    (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
            MOTHER=K(NSD(JT)+3,5)/MSTU(5)
            MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
          ENDIF
          IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
        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 660 I=NSHBEF+1,NSHAFT
              IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
  660       CONTINUE
          ENDIF
          IF(K(NSD2,1).GT.10) THEN
            DO 670 I=NSHBEF+1,NSHAFT
              IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
     &        I.NE.NSD1) NSD2=I
  670       CONTINUE
          ENDIF
          IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
            DO 680 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
  680       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)
  690 CONTINUE
 
 
C...Fill information for 2 -> 1 -> 2.
  700 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)
        IF(MINT(51).NE.0) RETURN
      ENDIF
 
C...Loop back if needed.
  710 IF(IP.LT.NP) GOTO 170
 
C...Boost back to standard frame.
  720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
     &BEZIN)
 
      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,P83A,P83B,P83C,
     &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
     &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
 
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))
        P83A=(1D0-PARP(83))**2
        P83B=2D0*PARP(83)*(1D0-PARP(83))
        P83C=PARP(83)**2
        CQ2I=1D0/PARP(84)**2
        CQ2R=2D0/(1D0+PARP(84)**2)
        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. Find where to divide the b range.
        IF(MSTP(82).EQ.2) THEN
          SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
          SOP=SP/PARU(1)
        ELSE
          IF(MSTP(82).EQ.3) THEN
            DELTAB=0.02D0
          ELSEIF(MSTP(82).EQ.4) THEN
            DELTAB=MIN(0.01D0,0.05D0*PARP(84))
          ELSE
            POWIP=MAX(0.4D0,PARP(83))
            RPWIP=2D0/POWIP-1D0
            DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
            SO=0D0
          ENDIF
          SP=0D0
          SOP=0D0
          BSP=0D0
          SOHIGH=0D0
          IBDIV=0
          B=-0.5D0*DELTAB
  140     B=B+DELTAB
          IF(MSTP(82).EQ.3) THEN
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSE
            OV=EXP(-B**POWIP)/PARU(2)
            SO=SO+PARU(2)*B*DELTAB*OV
          ENDIF
          IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
          PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
          SP=SP+PARU(2)*B*DELTAB*PACC
          SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
          BSP=BSP+B*PARU(2)*B*DELTAB*PACC
          IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
            IBDIV=1 
            BDIV=B+0.5D0*DELTAB
          ENDIF
          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.
        BAVG=BSP/SP
        VINT(145)=SIGSUM
        VINT(146)=SOP/SO
        VINT(147)=SOP/SP
        VNT145=VINT(145)
        VNT146=VINT(146)
        VNT147=VINT(147)
C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
        PIK=(VNT146/VNT147)*YKE

C...Find relative weight for low and high impact parameter.
      PLOWB=PARU(1)*BDIV**2
      IF(MSTP(82).EQ.3) THEN
        PHIGHB=PIK*0.5*EXP(-BDIV**2)
      ELSEIF(MSTP(82).EQ.4) THEN
        S4A=P83A*EXP(-BDIV**2)
        S4B=P83B*EXP(-BDIV**2*CQ2R)
        S4C=P83C*EXP(-BDIV**2*CQ2I)
        PHIGHB=PIK*0.5*(S4A+S4B+S4C)
      ELSEIF(PARP(83).GE.1.999D0) THEN
        PHIGHB=PIK*SOHIGH
        B2RPDV=BDIV**POWIP
      ELSE
        PHIGHB=PIK*SOHIGH
        B2RPDV=BDIV**POWIP
        B2RPMX=MAX(2D0*RPWIP,B2RPDV)
      ENDIF 
      PALLB=PLOWB+PHIGHB
 
C...Initialize iteration in xT2 for hardest interaction.
      ELSEIF(MMUL.EQ.2) THEN
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        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=VNT146*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

C...Select impact parameter for hardest interaction.
        IF(MSTP(82).LE.2) RETURN
  142   IF(PYR(0)*PALLB.LT.PLOWB) THEN
C...Treatment in low b region.
          MINT(39)=1
          B=BDIV*SQRT(PYR(0)) 
          IF(MSTP(82).EQ.3) THEN
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSE
            OV=EXP(-B**POWIP)/PARU(2)
          ENDIF  
          VINT(148)=OV/VNT147
          PACC=1D0-EXP(-MIN(50D0,PIK*OV))
          XT2=1D0
          XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
     &    VINT(149)*(1D0+VINT(149))
        ELSE
C...Treatment in high b region.
          MINT(39)=2
          IF(MSTP(82).EQ.3) THEN
            B=SQRT(BDIV**2-LOG(PYR(0)))
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            S4RNDM=PYR(0)*(S4A+S4B+S4C)
            IF(S4RNDM.LT.S4A) THEN
              B=SQRT(BDIV**2-LOG(PYR(0)))
            ELSEIF(S4RNDM.LT.S4A+S4B) THEN
              B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
            ELSE
              B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
            ENDIF    
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSEIF(PARP(83).GE.1.999D0) THEN
  144       B2RPW=B2RPDV-LOG(PYR(0))
            ACCIP=(B2RPW/B2RPDV)**RPWIP
            IF(ACCIP.LT.PYR(0)) GOTO 144
            OV=EXP(-B2RPW)/PARU(2)
            B=B2RPW**(1D0/POWIP)
          ELSE
  146       B2RPW=B2RPDV-2D0*LOG(PYR(0))
            ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
            IF(ACCIP.LT.PYR(0)) GOTO 146
            OV=EXP(-B2RPW)/PARU(2)
            B=B2RPW**(1D0/POWIP)
          ENDIF  
          VINT(148)=OV/VNT147
          PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
        ENDIF
        IF(PACC.LT.PYR(0)) GOTO 142
        VINT(139)=B/BAVG
 
      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)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        IF(MSTP(82).LE.0) THEN
          XT2=0D0
        ELSEIF(MSTP(82).EQ.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
C...Use with "Sudakov" for low b values when impact parameter dependence.
        ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) 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)
C...Use without "Sudakov" for high b values when impact parameter dep.
        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)-MINT(143)
          IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
          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)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        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 if not already done.
      ELSEIF(MMUL.EQ.5) THEN
        ISUB=MINT(1)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
  150   IF(MINT(39).GT.0) THEN
        ELSEIF(MSTP(82).EQ.3) THEN
          EXPB2=PYR(0)
          B2=-LOG(PYR(0))
          VINT(148)=EXPB2/(PARU(2)*VNT147)
          VINT(139)=SQRT(B2)/BAVG
        ELSEIF(MSTP(82).EQ.4) THEN
          RTYPE=PYR(0)
          IF(RTYPE.LT.P83A) THEN
            B2=-LOG(PYR(0))
          ELSEIF(RTYPE.LT.P83A+P83B) THEN
            B2=-LOG(PYR(0))/CQ2R
          ELSE
            B2=-LOG(PYR(0))/CQ2I
          ENDIF
          VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
     &    P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
     &    P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
          VINT(139)=SQRT(B2)/BAVG
        ELSEIF(PARP(83).GE.1.999D0) THEN
          POWIP=MAX(2D0,PARP(83))
          RPWIP=2D0/POWIP-1D0
          PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
  160     IF(PYR(0).LT.PROB1) THEN
            B2RPW=PYR(0)**(0.5D0*POWIP)
            ACCIP=EXP(-B2RPW)
          ELSE
            B2RPW=1D0-LOG(PYR(0))
            ACCIP=B2RPW**RPWIP
          ENDIF
          IF(ACCIP.LT.PYR(0)) GOTO 160
          VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
          VINT(139)=B2RPW**(1D0/POWIP)/BAVG
        ELSE
          POWIP=MAX(0.4D0,PARP(83))
          RPWIP=2D0/POWIP-1D0
          PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
  170     IF(PYR(0).LT.PROB1) THEN
            B2RPW=2D0*RPWIP*PYR(0)
            ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
          ELSE
            B2RPW=2D0*(RPWIP-LOG(PYR(0)))
            ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
          ENDIF
          IF(ACCIP.LT .PYR(0)) GOTO 170
          VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
          VINT(139)=B2RPW**(1D0/POWIP)/BAVG
        ENDIF
 
C...Multiple interactions (variable impact parameter) : reject with
C...probability exp(-overlap*cross-section above pT/normalization).
C...Does not apply to low-b region, where "Sudakov" already included.
        VINT(150)=1D0 
        IF(MINT(39).NE.1) THEN
          RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
          SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
          DO 180 IBIN=IRBIN+1,20
            RNCOR=RNCOR+NMUL(IBIN)
            SIGCOR=SIGCOR+SIGM(IBIN)
  180     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,VNT146*VINT(148)*
     &    SIGABV/MAX(1D-10,SIGT(0,0,5))))
        ENDIF
        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 150
          VINT(150)=1D0
        ENDIF
 
C...Generate additional multiple semihard interactions.
      ELSEIF(MMUL.EQ.6) THEN
        ISUBSV=MINT(1)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        DO 190 J=11,80
          VINTSV(J)=VINT(J)
  190   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 210 I=MINT(84)+1,NMAX
          KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
          IF(KCS.EQ.0) GOTO 210
          DO 200 J=1,4
            IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
            IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
            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 200
            IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
            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
  200     CONTINUE
  210   CONTINUE
 
C...Set up starting values for iteration in xT2.
        XT2=4D0*VINT(62)/VINT(2)
        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=VNT146*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.
  220   IF(MSTP(82).LE.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
          IF(XT2.LT.VINT(149)) GOTO 270
        ELSE
          IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
          XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
     &    LOG(PYR(0)))-VINT(149)
          IF(XT2.LE.0D0) GOTO 270
          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 220
        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 220
 
C...Reset K, P and V vectors. Select some variables.
        DO 240 I=N+1,N+2
          DO 230 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  230     CONTINUE
  240   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 260 I=N+1,N+2
            DMIN=1D8
            DO 250 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
  250       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
  260     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...Global statistics.
        MINT(351)=MINT(351)+1
        VINT(351)=VINT(351)+PT
        IF (MINT(351).EQ.1) VINT(356)=PT
 
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')
          MINT(51)=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)
C...Allow FSR for UE (always handle with old showers)
        IF(MSTP(152).EQ.1) THEN
          M41SAV=MSTJ(41)
          IF (MSTJ(41).EQ.10) MSTJ(41)=2
          MSTJ(41)=MOD(MSTJ(41),10)
          CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
          MSTJ(41)=M41SAV
        ENDIF
        IF(MINT(31).LT.240) GOTO 220
  270   CONTINUE
        MINT(1)=ISUBSV
        DO 280 J=11,80
          VINT(J)=VINTSV(J)
  280   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.MOD(MSTP(81),10).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(I2+1,MINT(52),0D0,-ROBO(2),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.100) 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
        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...PYMIGN
C...Initializes treatment of new multiple interactions scenario,
C...selects kinematics of hardest interaction if low-pT physics
C...included in run, and generates all non-hardest interactions.
 
      SUBROUTINE PYMIGN(MMUL)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
      EXTERNAL PYALPS
      DOUBLE PRECISION PYALPS
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(8000,2),BRAT(8000),KFDP(8000,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/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
      COMMON/PYINT7/SIGT(0:6,0:6,0:5)
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
C...Local arrays and saved variables.
      DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
     &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
      SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
     &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
     &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
 
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))
        P83A=(1D0-PARP(83))**2
        P83B=2D0*PARP(83)*(1D0-PARP(83))
        P83C=PARP(83)**2
        CQ2I=1D0/PARP(84)**2
        CQ2R=2D0/(1D0+PARP(84)**2)
        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. Find where to divide the b range.
        IF(MSTP(82).EQ.2) THEN
          SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
          SOP=SP/PARU(1)
        ELSE
          IF(MSTP(82).EQ.3) THEN
            DELTAB=0.02D0
          ELSEIF(MSTP(82).EQ.4) THEN
            DELTAB=MIN(0.01D0,0.05D0*PARP(84))
          ELSE
            POWIP=MAX(0.4D0,PARP(83))
            RPWIP=2D0/POWIP-1D0
            DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
            SO=0D0
          ENDIF
          SP=0D0
          SOP=0D0
          BSP=0D0
          SOHIGH=0D0
          IBDIV=0
          B=-0.5D0*DELTAB
  140     B=B+DELTAB
          IF(MSTP(82).EQ.3) THEN
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSE
            OV=EXP(-B**POWIP)/PARU(2)
            SO=SO+PARU(2)*B*DELTAB*OV
          ENDIF
          IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
          PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
          SP=SP+PARU(2)*B*DELTAB*PACC
          SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
          BSP=BSP+B*PARU(2)*B*DELTAB*PACC
          IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
            IBDIV=1 
            BDIV=B+0.5D0*DELTAB
          ENDIF
          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.
        BAVG=BSP/SP
        VINT(145)=SIGSUM
        VINT(146)=SOP/SO
        VINT(147)=SOP/SP
        VNT145=VINT(145)
        VNT146=VINT(146)
        VNT147=VINT(147)
C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
        PIK=(VNT146/VNT147)*YKE

C...Find relative weight for low and high impact parameter..
      PLOWB=PARU(1)*BDIV**2
      IF(MSTP(82).EQ.3) THEN
        PHIGHB=PIK*0.5*EXP(-BDIV**2)
      ELSEIF(MSTP(82).EQ.4) THEN
        S4A=P83A*EXP(-BDIV**2)
        S4B=P83B*EXP(-BDIV**2*CQ2R)
        S4C=P83C*EXP(-BDIV**2*CQ2I)
        PHIGHB=PIK*0.5*(S4A+S4B+S4C)
      ELSEIF(PARP(83).GE.1.999D0) THEN
        PHIGHB=PIK*SOHIGH
        B2RPDV=BDIV**POWIP
      ELSE
        PHIGHB=PIK*SOHIGH
        B2RPDV=BDIV**POWIP
        B2RPMX=MAX(2D0*RPWIP,B2RPDV)
      ENDIF 
      PALLB=PLOWB+PHIGHB
 
C...Initialize iteration in xT2 for hardest interaction.
      ELSEIF(MMUL.EQ.2) THEN
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        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=VNT146*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

C...Select impact parameter for hardest interaction.
        IF(MSTP(82).LE.2) RETURN
  142   IF(PYR(0)*PALLB.LT.PLOWB) THEN
C...Treatment in low b region.
          MINT(39)=1
          B=BDIV*SQRT(PYR(0)) 
          IF(MSTP(82).EQ.3) THEN
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSE
            OV=EXP(-B**POWIP)/PARU(2)
          ENDIF  
          VINT(148)=OV/VNT147
          PACC=1D0-EXP(-MIN(50D0,PIK*OV))
          XT2=1D0
          XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
     &    VINT(149)*(1D0+VINT(149))
        ELSE
C...Treatment in high b region.
          MINT(39)=2
          IF(MSTP(82).EQ.3) THEN
            B=SQRT(BDIV**2-LOG(PYR(0)))
            OV=EXP(-B**2)/PARU(2)
          ELSEIF(MSTP(82).EQ.4) THEN
            S4RNDM=PYR(0)*(S4A+S4B+S4C)
            IF(S4RNDM.LT.S4A) THEN
              B=SQRT(BDIV**2-LOG(PYR(0)))
            ELSEIF(S4RNDM.LT.S4A+S4B) THEN
              B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
            ELSE
              B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
            ENDIF    
            OV=(P83A*EXP(-MIN(50D0,B**2))+
     &      P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
     &      P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
          ELSEIF(PARP(83).GE.1.999D0) THEN
  144       B2RPW=B2RPDV-LOG(PYR(0))
            ACCIP=(B2RPW/B2RPDV)**RPWIP
            IF(ACCIP.LT.PYR(0)) GOTO 144
            OV=EXP(-B2RPW)/PARU(2)
            B=B2RPW**(1D0/POWIP)
          ELSE
  146       B2RPW=B2RPDV-2D0*LOG(PYR(0))
            ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
            IF(ACCIP.LT.PYR(0)) GOTO 146
            OV=EXP(-B2RPW)/PARU(2)
            B=B2RPW**(1D0/POWIP)
          ENDIF  
          VINT(148)=OV/VNT147
          PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
        ENDIF
        IF(PACC.LT.PYR(0)) GOTO 142
        VINT(139)=B/BAVG
 
      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)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        IF(MSTP(82).LE.0) THEN
          XT2=0D0
        ELSEIF(MSTP(82).EQ.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
C...Use with "Sudakov" for low b values when impact parameter dependence.
        ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) 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)
C...Use without "Sudakov" for high b values when impact parameter dep.
        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)-MINT(143)
          IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
          ISUB=95
          MINT(1)=ISUB
          VINT(21)=1D-12*VINT(149)
          VINT(22)=0D0
          VINT(23)=0D0
          VINT(25)=1D-12*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)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        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 if not already done.
      ELSEIF(MMUL.EQ.5) THEN
        ISUB=MINT(1)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
  150   IF(MINT(39).GT.0) THEN
        ELSEIF(MSTP(82).EQ.3) THEN
          EXPB2=PYR(0)
          B2=-LOG(PYR(0))
          VINT(148)=EXPB2/(PARU(2)*VNT147)
          VINT(139)=SQRT(B2)/BAVG
        ELSEIF(MSTP(82).EQ.4) THEN
          RTYPE=PYR(0)
          IF(RTYPE.LT.P83A) THEN
            B2=-LOG(PYR(0))
          ELSEIF(RTYPE.LT.P83A+P83B) THEN
            B2=-LOG(PYR(0))/CQ2R
          ELSE
            B2=-LOG(PYR(0))/CQ2I
          ENDIF
          VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
     &    P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
     &    P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
          VINT(139)=SQRT(B2)/BAVG
        ELSEIF(PARP(83).GE.1.999D0) THEN
          POWIP=MAX(2D0,PARP(83))
          RPWIP=2D0/POWIP-1D0
          PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
  160     IF(PYR(0).LT.PROB1) THEN
            B2RPW=PYR(0)**(0.5D0*POWIP)
            ACCIP=EXP(-B2RPW)
          ELSE
            B2RPW=1D0-LOG(PYR(0))
            ACCIP=B2RPW**RPWIP
          ENDIF
          IF(ACCIP.LT.PYR(0)) GOTO 160
          VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
          VINT(139)=B2RPW**(1D0/POWIP)/BAVG
        ELSE
          POWIP=MAX(0.4D0,PARP(83))
          RPWIP=2D0/POWIP-1D0
          PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
  170     IF(PYR(0).LT.PROB1) THEN
            B2RPW=2D0*RPWIP*PYR(0)
            ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
          ELSE
            B2RPW=2D0*(RPWIP-LOG(PYR(0)))
            ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
          ENDIF
          IF(ACCIP.LT .PYR(0)) GOTO 170
          VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
          VINT(139)=B2RPW**(1D0/POWIP)/BAVG
        ENDIF
 
C...Multiple interactions (variable impact parameter) : reject with
C...probability exp(-overlap*cross-section above pT/normalization).
C...Does not apply to low-b region, where "Sudakov" already included.
        VINT(150)=1D0 
        IF(MINT(39).NE.1) THEN
          RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
          SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
          DO 180 IBIN=IRBIN+1,20
            RNCOR=RNCOR+NMUL(IBIN)
            SIGCOR=SIGCOR+SIGM(IBIN)
  180     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,VNT146*VINT(148)*
     &    SIGABV/MAX(1D-10,SIGT(0,0,5))))
        ENDIF
        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 150
          VINT(150)=1D0
        ENDIF
 
C...Generate additional multiple semihard interactions.
      ELSEIF(MMUL.EQ.6) THEN
 
C...Save data for hardest initeraction, to be restored.
        ISUBSV=MINT(1)
        VINT(145)=VNT145
        VINT(146)=VNT146
        VINT(147)=VNT147
        M13SV=MINT(13)
        M14SV=MINT(14)
        M15SV=MINT(15)
        M16SV=MINT(16)
        M21SV=MINT(21)
        M22SV=MINT(22)
        DO 190 J=11,80
          VINTSV(J)=VINT(J)
  190   CONTINUE
        V141SV=VINT(141)
        V142SV=VINT(142)
 
C...Store data on hardest interaction.
        XMI(1,1)=VINT(141)
        XMI(2,1)=VINT(142)
        PT2MI(1)=VINT(54)
        IMISEP(0)=MINT(84)
        IMISEP(1)=N
 
C...Change process to generate; sum of x values so far.
        ISUB=96
        MINT(1)=96
        VINT(143)=1D0-VINT(141)
        VINT(144)=1D0-VINT(142)
        VINT(151)=0D0
        VINT(152)=0D0
 
C...Initialize factors for PDF reshaping.
        DO 230 JS=1,2
          KFBEAM=MINT(10+JS)
          KFABM=IABS(KFBEAM)
          KFSBM=ISIGN(1,KFBEAM)
 
C...Zero flavour content of incoming beam particle.
          KFIVAL(JS,1)=0
          KFIVAL(JS,2)=0
          KFIVAL(JS,3)=0
C...Flavour content of baryon.
          IF(KFABM.GT.1000) THEN
            KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
            KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
            KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
C...Flavour content of pi+-, K+-.
          ELSEIF(KFABM.EQ.211) THEN
            KFIVAL(JS,1)=KFSBM*2
            KFIVAL(JS,2)=-KFSBM
          ELSEIF(KFABM.EQ.321) THEN
            KFIVAL(JS,1)=-KFSBM*3
            KFIVAL(JS,2)=KFSBM*2
C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
          ENDIF
 
C...Zero initial valence and companion content.
          DO 200 IFL=-6,6
            NVC(JS,IFL)=0
  200     CONTINUE
 
C...Initiate listing of all incoming partons from two sides.
          NMI(JS)=0
          DO 210 I=MINT(84)+1,N
            IF(K(I,3).EQ.MINT(83)+2+JS) THEN
              IMI(JS,1,1)=I
              IMI(JS,1,2)=0
            ENDIF
  210     CONTINUE
 
C...Decide whether quarks in hard scattering were valence or sea.
          IFL=K(IMI(JS,1,1),2)
          IF (IABS(IFL).GT.6) GOTO 230
 
C...Get PDFs at X and Q2 of the parton shower initiator for the
C...hard scattering.
          X=VINT(140+JS)
          IF(MSTP(61).GE.1) THEN
            Q2=PARP(62)**2
          ELSE
            Q2=VINT(54)
          ENDIF
C...Note: XPSVC = x*pdf.
          MINT(30)=JS
          CALL PYPDFU(KFBEAM,X,Q2,XPQ)
          SEA=XPSVC(IFL,-1)
          VAL=XPSVC(IFL,0)
 
C...Decide (Extra factor x cancels in the division).
          RVCS=PYR(0)*(SEA+VAL)
          IVNOW=1
  220     IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
            IVNOW=0
            IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,1).EQ.0) THEN
              IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
              IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
              IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
     &        (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
            ENDIF
            IF(IVNOW.EQ.0) GOTO 220
C...Mark valence.
            IMI(JS,1,2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
            IF(KFIVAL(JS,1).EQ.0) THEN
              IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
                KFIVAL(JS,1)=IFL
                KFIVAL(JS,2)=-IFL
              ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
                KFIVAL(JS,1)=IFL
                IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
                IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
              ENDIF
            ENDIF
 
C...If sea, add opposite sign companion parton. Store X and I.
          ELSE
            NVC(JS,-IFL)=NVC(JS,-IFL)+1
            XASSOC(JS,-IFL,NVC(JS,-IFL))=X
C...Set pointer to companion
            IMI(JS,1,2)=-NVC(JS,-IFL)
          ENDIF
  230   CONTINUE
 
C...Update counter number of multiple interactions.
        NMI(1)=1
        NMI(2)=1
 
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=VNT146*VINT(148)*XSEC(ISUB,1)/
     &    MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
        ENDIF
        VINT(63)=0D0
        VINT(64)=0D0
 
C...Iterate downwards in xT2.
  240   IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
          XT2=0D0
          GOTO 440
        ELSEIF(MSTP(82).LE.1) THEN
          XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
          IF(XT2.LT.VINT(149)) GOTO 440
        ELSE
          IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
          XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
     &    LOG(PYR(0)))-VINT(149)
          IF(XT2.LE.0D0) GOTO 440
          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
C...New: require shat > 1.
        IF(TAU*VINT(2).LT.1D0) GOTO 240
        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 240
        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 240
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
 
C...Reset K, P and V vectors.
        DO 260 I=N+1,N+4
          DO 250 J=1,5
            K(I,J)=0
            P(I,J)=0D0
            V(I,J)=0D0
  250     CONTINUE
  260   CONTINUE
        PT=0.5D0*VINT(1)*SQRT(XT2)
 
C...Choose flavour of reacting partons (and subprocess).
        RSIGS=SIGS*PYR(0)
        DO 270 ICHN=1,NCHN
          KFL1=ISIG(ICHN,1)
          KFL2=ISIG(ICHN,2)
          ICONMI=ISIG(ICHN,3)
          RSIGS=RSIGS-SIGH(ICHN)
          IF(RSIGS.LE.0D0) GOTO 280
  270   CONTINUE
 
C...Reassign to appropriate process codes.
  280   ISUBMI=ICONMI/10
        ICONMI=MOD(ICONMI,10)
 
C...Choose new quark flavour for annihilation graphs
        IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
          SH=TAU*VINT(2)
          CALL PYWIDT(21,SH,WDTP,WDTE)
  290     RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
          DO 300 I=1,MDCY(21,3)
            KFLF=KFDP(I+MDCY(21,2)-1,1)
            RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
            IF(RKFL.LE.0D0) GOTO 310
  300     CONTINUE
  310     IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
            IF(KFLF.GE.4) GOTO 290
          ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
            KFLF=4
            ICONMI=ICONMI-2
          ELSEIF(ISUBMI.EQ.53) THEN
            KFLF=5
            ICONMI=ICONMI-4
          ENDIF
        ENDIF
 
C...Final state flavours and colour flow: default values
        JS=1
        KFL3=KFL1
        KFL4=KFL2
        KCC=20
        KCS=ISIGN(1,KFL1)
 
        IF(ISUBMI.EQ.11) THEN
C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
          KCC=ICONMI
          IF(KFL1*KFL2.LT.0) KCC=KCC+2
 
        ELSEIF(ISUBMI.EQ.12) THEN
C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
          KFL3=ISIGN(KFLF,KFL1)
          KFL4=-KFL3
          KCC=4
 
        ELSEIF(ISUBMI.EQ.13) THEN
C...f + fbar -> g + g; th arbitrary
          KFL3=21
          KFL4=21
          KCC=ICONMI+4
 
        ELSEIF(ISUBMI.EQ.28) THEN
C...f + g -> f + g; th = (p(f)-p(f))**2
          IF(KFL1.EQ.21) JS=2
          KCC=ICONMI+6
          IF(KFL1.EQ.21) KCC=KCC+2
          IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
          IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
 
        ELSEIF(ISUBMI.EQ.53) THEN
C...g + g -> f + fbar; th arbitrary
          KCS=(-1)**INT(1.5D0+PYR(0))
          KFL3=ISIGN(KFLF,KCS)
          KFL4=-KFL3
          KCC=ICONMI+10
 
        ELSEIF(ISUBMI.EQ.68) THEN
C...g + g -> g + g; th arbitrary
          KCC=ICONMI+12
          KCS=(-1)**INT(1.5D0+PYR(0))
        ENDIF
 
C...Store flavours of scattering.
        MINT(13)=KFL1
        MINT(14)=KFL2
        MINT(15)=KFL1
        MINT(16)=KFL2
        MINT(21)=KFL3
        MINT(22)=KFL4
 
C...Set flavours and mothers of scattering partons.
        K(N+1,1)=14
        K(N+2,1)=14
        K(N+3,1)=3
        K(N+4,1)=3
        K(N+1,2)=KFL1
        K(N+2,2)=KFL2
        K(N+3,2)=KFL3
        K(N+4,2)=KFL4
        K(N+1,3)=MINT(83)+1
        K(N+2,3)=MINT(83)+2
        K(N+3,3)=N+1
        K(N+4,3)=N+2
 
C...Store colour connection indices.
        DO 320 J=1,2
          JC=J
          IF(KCS.EQ.-1) JC=3-J
          IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
          IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
          IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
          IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
  320   CONTINUE
 
C...Store incoming and outgoing partons in their CM-frame.
        SHR=SQRT(TAU)*VINT(1)
        P(N+1,3)=0.5D0*SHR
        P(N+1,4)=0.5D0*SHR
        P(N+2,3)=-0.5D0*SHR
        P(N+2,4)=0.5D0*SHR
        P(N+3,5)=PYMASS(K(N+3,2))
        P(N+4,5)=PYMASS(K(N+4,2))
        IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
        P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
        P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
        P(N+4,4)=SHR-P(N+3,4)
        P(N+4,3)=-P(N+3,3)
 
C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
        PHI=PARU(2)*PYR(0)
        CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
 
C...Set up default values before showers.
        MINT(31)=MINT(31)+1
        IPU1=N+1
        IPU2=N+2
        IPU3=N+3
        IPU4=N+4
        VINT(141)=VINT(41)
        VINT(142)=VINT(42)
        N=N+4
 
C...Showering of initial state partons (optional).
C...Note: no showering of final state partons here; it comes later.
        IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
          MINT(51)=0
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          NSAV=N
          DO 340 I=1,4
            DO 330 J=1,5
              KSAV(I,J)=K(N-4+I,J)
              PSAV(I,J)=P(N-4+I,J)
  330       CONTINUE
  340     CONTINUE
          CALL PYSSPA(IPU1,IPU2)
          PARJ(81)=ALAMSV
C...If shower failed then restore to situation before shower.
          IF(MINT(51).GE.1) THEN
            N=NSAV
            DO 360 I=1,4
              DO 350 J=1,5
                K(N-4+I,J)=KSAV(I,J)
                P(N-4+I,J)=PSAV(I,J)
  350         CONTINUE
  360       CONTINUE
            IPU1=N-3
            IPU2=N-2
            VINT(141)=VINT(41)
            VINT(142)=VINT(42)
          ENDIF
        ENDIF
 
C...Keep track of loose colour ends and information on scattering.
  370   IMI(1,MINT(31),1)=IPU1
        IMI(2,MINT(31),1)=IPU2
        IMI(1,MINT(31),2)=0
        IMI(2,MINT(31),2)=0
        XMI(1,MINT(31))=VINT(141)
        XMI(2,MINT(31))=VINT(142)
        PT2MI(MINT(31))=VINT(54)
        IMISEP(MINT(31))=N
 
C...Decide whether quarks in last scattering were valence, companion or
C...sea.
        DO 430 JS=1,2
          KFBEAM=MINT(10+JS)
          KFSBM=ISIGN(1,MINT(10+JS))
          IFL=K(IMI(JS,MINT(31),1),2)
          IMI(JS,MINT(31),2)=0
          IF (IABS(IFL).GT.6) GOTO 430
 
C...Get PDFs at X and Q2 of the parton shower initiator for the
C...last scattering. At this point VINT(143:144) do not yet
C...include the scattered x values VINT(141:142).
          X=VINT(140+JS)/VINT(142+JS)
          IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
            Q2=PARP(62)**2
          ELSE
            Q2=VINT(54)
          ENDIF
C...Note: XPSVC = x*pdf.
          MINT(30)=JS
          CALL PYPDFU(KFBEAM,X,Q2,XPQ)
          SEA=XPSVC(IFL,-1)
          VAL=XPSVC(IFL,0)
          CMP=0D0
          DO 380 IVC=1,NVC(JS,IFL)
            CMP=CMP+XPSVC(IFL,IVC)
  380     CONTINUE
 
C...Decide (Extra factor x cancels in the dvision).
          RVCS=PYR(0)*(SEA+VAL+CMP)
          IVNOW=1
  390     IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
            IVNOW=0
            IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
            IF(KFIVAL(JS,1).EQ.0) THEN
              IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
              IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
              IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
     &        (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
            ELSE
              DO 400 I1=1,NMI(JS)
                IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
     &            IVNOW=IVNOW-1
  400         CONTINUE
            ENDIF
            IF(IVNOW.EQ.0) GOTO 390
C...Mark valence.
            IMI(JS,MINT(31),2)=0
C...Sets valence content of gamma, pi0, K0S, K0L if not done.
            IF(KFIVAL(JS,1).EQ.0) THEN
              IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
                KFIVAL(JS,1)=IFL
                KFIVAL(JS,2)=-IFL
              ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
                KFIVAL(JS,1)=IFL
                IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
                IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
              ENDIF
            ENDIF
 
          ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
C...If sea, add opposite sign companion parton. Store X and I.
            NVC(JS,-IFL)=NVC(JS,-IFL)+1
            XASSOC(JS,-IFL,NVC(JS,-IFL))=X
C...Set pointer to companion
            IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
          ELSE
C...If companion, decide which one.
            CMPSUM=VAL+SEA
            ISEL=0
  410       ISEL=ISEL+1
            CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
            IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
C...Find original sea (anti-)quark:
            IASSOC=0
            DO 420 I1=1,NMI(JS)
              IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
              IF (-IMI(JS,I1,2).EQ.ISEL) THEN
                IMI(JS,MINT(31),2)=IMI(JS,I1,1)
                IMI(JS,I1,2)=IMI(JS,MINT(31),1)
              ENDIF
  420       CONTINUE
C...Change X to what associated companion had, so that the correct
C...amount of momentum can be subtracted from the companion sum below.
            X=XASSOC(JS,IFL,ISEL)
C...Mark companion read.
            XASSOC(JS,IFL,ISEL)=0D0
          ENDIF
 430    CONTINUE
 
C...Global statistics.
        MINT(351)=MINT(351)+1
        VINT(351)=VINT(351)+PT
        IF (MINT(351).EQ.1) VINT(356)=PT
 
C...Update remaining energy and other counters.
        IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
          CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
          MINT(51)=1
          RETURN
        ENDIF
        NMI(1)=NMI(1)+1
        NMI(2)=NMI(2)+1
        VINT(151)=VINT(151)+VINT(41)
        VINT(152)=VINT(152)+VINT(42)
        VINT(143)=VINT(143)-VINT(141)
        VINT(144)=VINT(144)-VINT(142)
 
C...Iterate, with more interactions allowed.
        IF(MINT(31).LT.240) GOTO 240
 440    CONTINUE
 
C...Restore saved quantities for hardest interaction.
        MINT(1)=ISUBSV
        MINT(13)=M13SV
        MINT(14)=M14SV
        MINT(15)=M15SV
        MINT(16)=M16SV
        MINT(21)=M21SV
        MINT(22)=M22SV
        DO 450 J=11,80
          VINT(J)=VINTSV(J)
  450   CONTINUE
        VINT(141)=V141SV
        VINT(142)=V142SV
 
      ENDIF
 
C...Format statements for printout.
 5000 FORMAT(/1X,'****** PYMIGN: 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...PYMIHK
C...Finds left-behind remnant flavour content and hooks up
C...the colour flow between the hard scattering and remnants
 
      SUBROUTINE PYMIHK
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...The event record
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
C...Parameters
      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)
C...The common block of dangling ends
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
C...Local variables
      PARAMETER (NERSIZ=4000)
      COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
     &     ,MACCPT
      COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
      SAVE /PYCBLS/,/PYCTAG/
      DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
     &     ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
      DATA NERRPR/0/
      SAVE NERRPR
      FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1)
 
C...Set up error checkers
      IBOOST=0
 
C...Initialize colour arrays: MCO (Original) and MCT (New)
      DO 110 I=MINT(84)+1,NERSIZ
        DO 100 JC=1,2
          MCT(I,JC)=0
          MCO(I,JC)=0
  100   CONTINUE
C...Also zero colour tracing information, if existed.
        IF (I.LE.N) THEN
          K(I,4)=MOD(K(I,4),MSTU(5)**2)
          K(I,5)=MOD(K(I,5),MSTU(5)**2)
        ENDIF
  110 CONTINUE
 
C...Initialize colour tag collapse arrays:
C...JCCO (Original) and JCCN (New).
      DO 130 MG=MINT(84)+1,NERSIZ
        DO 120 JC=1,2
          JCCO(MG,JC)=0
          JCCN(MG,JC)=0
  120   CONTINUE
  130 CONTINUE
 
C...Zero gluon insertion array
      DO 150 IM=1,1000
        DO 140 J=1,3
          INSR(IM,J)=0
  140   CONTINUE
  150 CONTINUE
 
C...Compute hard scattering system rapidities
      IF (MSTP(89).EQ.1) THEN
        DO 160 IM=1,240
          IF (IM.LE.MINT(31)) THEN
            YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
          ELSE
C...Set (unsigned) rapidity = 100 for beam remnant systems.
            YMI(IM)=100D0
          ENDIF
  160   CONTINUE
      ENDIF
 
C...Treat each side separately
      DO 290 JS=1,2
 
C...Initialize side.
        NG(JS)=0
        JV=0
        KFS=ISIGN(1,MINT(10+JS))
 
C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
        IF(KFIVAL(JS,1).EQ.0) THEN
          IF(MINT(10+JS).EQ.111) THEN
            KFIVAL(JS,1)=INT(1.5D0+PYR(0))
            KFIVAL(JS,2)=-KFIVAL(JS,1)
          ELSEIF(MINT(10+JS).EQ.22) THEN
            PYRKF=PYR(0)
            KFIVAL(JS,1)=1
            IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
            IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
            IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
            KFIVAL(JS,2)=-KFIVAL(JS,1)
          ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
            IF(PYR(0).GT.0.5D0) THEN
              KFIVAL(JS,1)=1
              KFIVAL(JS,2)=-3
            ELSE
              KFIVAL(JS,1)=3
              KFIVAL(JS,2)=-1
            ENDIF
          ENDIF
        ENDIF
 
C...Initialize beam remnant sea and valence content flavour by flavour.
        NVSUM(JS)=0
        NBRTOT(JS)=0
        DO 210 JFA=1,6
C...Count up original number of JFA valence quarks and antiquarks.
          NVALQ=0
          NVALQB=0
          NSEA=0
          DO 170 J=1,3
            IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
            IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
  170     CONTINUE
          NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
C...Subtract kicked out valence and determine sea from flavour cons.
          DO 180 IM=1,NMI(JS)
            IFL = K(IMI(JS,IM,1),2)
            IFA = IABS(IFL)
            IFS = ISIGN(1,IFL)
            IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
C...Subtract K.O. valence quark from remainder.
              NVALQ=NVALQ-1
              JV=NVSUM(JS)-NVALQ-NVALQB
              IV(JS,JV)=IMI(JS,IM,1)
            ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
C...Subtract K.O. valence antiquark from remainder.
              NVALQB=NVALQB-1
              JV=NVSUM(JS)-NVALQ-NVALQB
              IV(JS,JV)=IMI(JS,IM,1)
            ELSEIF (IFA.EQ.JFA) THEN
C...Outside sea without companion: add opposite sea flavour inside.
              IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
            ENDIF
  180     CONTINUE
C...Check if space left in PYJETS for additional BR flavours
          NFLSUM=IABS(NSEA)+NVALQ+NVALQB
          NBRTOT(JS)=NBRTOT(JS)+NFLSUM
          IF (N+NFLSUM+1.GT.MSTU(4)) THEN
            CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
            MINT(51)=1
            RETURN
          ENDIF
C...Add required val+sea content to beam remnant.
          IF (NFLSUM.GT.0) THEN
            DO 200 IA=1,NFLSUM
C...Insert beam remnant quark as p.t. symbolic parton in ER.
              N=N+1
              DO 190 IX=1,5
                K(N,IX)=0
                P(N,IX)=0D0
                V(N,IX)=0D0
  190         CONTINUE
              K(N,1)=3
              K(N,2)=ISIGN(JFA,NSEA)
              IF (IA.LE.NVALQ) K(N,2)=JFA
              IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
              K(N,3)=MINT(83)+JS
C...Also update NMI, IMI, and IV arrays.
              NMI(JS)=NMI(JS)+1
              IMI(JS,NMI(JS),1)=N
              IMI(JS,NMI(JS),2)=-1
              IF (IA.LE.NVALQ+NVALQB) THEN
                IMI(JS,NMI(JS),2)=0
                JV=JV+1
                IV(JS,JV)=IMI(JS,NMI(JS),1)
              ENDIF
  200       CONTINUE
          ENDIF
  210   CONTINUE
 
        IM=0
  220   IM=IM+1
        IF (IM.LE.NMI(JS)) THEN
          IF (K(IMI(JS,IM,1),2).EQ.21) THEN
            NG(JS)=NG(JS)+1
C...Add fictitious parent gluons for companion pairs.
          ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
C...Randomly assign companions to sea quarks which have none.
            IF (IMI(JS,IM,2).LT.0) THEN
              IMC=PYR(0)*NMI(JS)
  230         IMC=MOD(IMC,NMI(JS))+1
              IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
              IF (IMI(JS,IMC,2).GE.0) GOTO 230
              IMI(JS, IM,2) = IMI(JS,IMC,1)
              IMI(JS,IMC,2) = IMI(JS, IM,1)
            ENDIF
C...Add fictitious parent gluon
            N=N+1
            DO 240 IX=1,5
              K(N,IX)=0
              P(N,IX)=0D0
              V(N,IX)=0D0
  240       CONTINUE
            K(N,1)=14
            K(N,2)=21
            K(N,3)=MINT(83)+JS
C...Set gluon (anti-)colour daughter pointers
            K(N,4)=IMI(JS, IM,1)
            K(N,5)=IMI(JS, IM,2)
C...Set quark (anti-)colour parent pointers
            K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
            K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
C...Add gluon to IMI
            NMI(JS)=NMI(JS)+1
            IMI(JS,NMI(JS),1)=N
            IMI(JS,NMI(JS),2)=0
          ENDIF
          GOTO 220
        ENDIF
 
C...If incoming (anti-)baryon, insert inside (anti-)junction.
C...Set up initial v-v-j-v configuration. Otherwise set up
C...mesonic v-vbar configuration
        IF (IABS(MINT(10+JS)).GT.1000) THEN
C...Determine junction type (1: B=1 2: B=-1)
          ITJUNC(JS) = (3-KFS)/2
C...Insert junction.
          N=N+1
          DO 250 IX=1,5
            K(N,IX)=0
            P(N,IX)=0D0
            V(N,IX)=0D0
  250     CONTINUE
C...Set special junction codes:
          K(N,1)=42
          K(N,2)=88
C...Set parent to side.
          K(N,3)=MINT(83)+JS
          K(N,4)=ITJUNC(JS)*MSTU(5)
          K(N,5)=0
C...Connect valence quarks to junction.
          MOUT(JS)=0
          MANTI=ITJUNC(JS)-1
C...Set (anti)colour mother = junction.
          DO 260 JV=1,3
            K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
     &           +MSTU(5)*N
C...Keep track of partons adjacent to junction:
            JST(JS,JV)=IV(JS,JV)
  260     CONTINUE
        ELSE
C...Mesons: set up initial q-qbar topology
          ITJUNC(JS)=0
          IF (K(IV(JS,1),2).GT.0) THEN
            IQ=IV(JS,1)
            IQBAR=IV(JS,2)
          ELSE
            IQ=IV(JS,2)
            IQBAR=IV(JS,1)
          ENDIF
          IV(JS,3)=0
          JST(JS,1)=IQ
          JST(JS,2)=IQBAR
          JST(JS,3)=0
          K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
          K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
C...Special for mesons. Insert gluon if BR empty.
          IF (NBRTOT(JS).EQ.0) THEN
            N=N+1
            DO 270 IX=1,5
              K(N,IX)=0
              P(N,IX)=0D0
              V(N,IX)=0D0
  270       CONTINUE
            K(N,1)=3
            K(N,2)=21
            K(N,3)=MINT(83)+JS
            K(N,4)=0
            K(N,5)=0
            NBRTOT(JS)=1
            NG(JS)=NG(JS)+1
C...Add gluon to IMI
            NMI(JS)=NMI(JS)+1
            IMI(JS,NMI(JS),1)=N
            IMI(JS,NMI(JS),2)=0
          ENDIF
          MOUT(JS)=0
        ENDIF
 
C...Count up number of valence quarks outside BR.
        DO 280 JV=1,3
          IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
     &         MOUT(JS)=MOUT(JS)+1
  280   CONTINUE
 
  290 CONTINUE
 
C...Now both sides have been prepared in an initial vvjv (baryonic) or
C...v(g)vbar (mesonic) configuration.
 
C...Create colour line tags starting from initiators.
      NCT=0
      DO 320 IM=1,MINT(31)
C...Consider each side in turn.
        DO 310 JS=1,2
          I1=IMI(JS,IM,1)
          I2=IMI(3-JS,IM,1)
          DO 300 JCS=4,5
            IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
     &           GOTO 300
            IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
 
            KCS=JCS
            CALL PYCTTR(I1,KCS,I2)
            IF(MINT(51).NE.0) RETURN
 
  300     CONTINUE
  310   CONTINUE
  320 CONTINUE
 
      DO 340 JS=1,2
C...Create colour tags for beam remnant partons.
        DO 330 IM=MINT(31)+1,NMI(JS)
          IP=IMI(JS,IM,1)
          IF (K(IP,2).NE.21) THEN
            JC=(3-ISIGN(1,K(IP,2)))/2
            IF (MCT(IP,JC).EQ.0) THEN
              NCT=NCT+1
              MCT(IP,JC)=NCT
            ENDIF
          ELSE
C...Gluons
            ICD=K(IP,4)
            IAD=K(IP,5)
            IF (ICD.NE.0) THEN
C...Fictituous gluons just inherit from their quark daughters.
              ICC=MCT(ICD,1)
              IAC=MCT(IAD,2)
            ELSE
C...Real beam remnant gluons get their own colours
              ICC=NCT+1
              IAC=NCT+2
              NCT=NCT+2
            ENDIF
            MCT(IP,1)=ICC
            MCT(IP,2)=IAC
          ENDIF
  330   CONTINUE
  340 CONTINUE
 
C...Create colour tags for colour lines which are detached from the
C...initial state.
 
      DO 360 MQGST=1,2
        DO 350 I=MINT(84)+1,N
 
C...Look for coloured string endpoint, or (later) leftover gluon.
          IF (K(I,1).NE.3) GOTO 350
          KC=PYCOMP(K(I,2))
          IF(KC.EQ.0) GOTO 350
          KQ=KCHG(KC,2)
          IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
 
C...Pick up loose string end with no previous tag.
          KCS=4
          IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
          IF(MCT(I,KCS-3).NE.0) GOTO 350
 
          CALL PYCTTR(I,KCS,I)
          IF(MINT(51).NE.0) RETURN
 
  350   CONTINUE
  360 CONTINUE
 
C...Store original colour tags
      DO 370 I=MINT(84)+1,N
        MCO(I,1)=MCT(I,1)
        MCO(I,2)=MCT(I,2)
  370 CONTINUE
 
C...Iteratively add gluons to already existing string pieces, enforcing
C...various possible orderings, and rejecting insertions that would give
C...rise to singlet gluons.
C...<kappa tau> normalization.
      RM0=1.5D0
      MRETRY=0
      PARP80=PARP(80)
 
C...Set up simplified kinematics.
C...Boost hard interaction systems.
      IBOOST=IBOOST+1
      DO 380 IM=1,MINT(31)
        BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
        CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
  380 CONTINUE
C...Assign preliminary beam remnant momenta.
      DO 390 I=MINT(53)+1,N
        JS=K(I,3)
        P(I,1)=0D0
        P(I,2)=0D0
        IF (K(I,2).NE.88) THEN
          P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
          P(I,3)=P(I,4)
          IF (JS.EQ.2) P(I,3)=-P(I,3)
        ELSE
C...Junctions are wildcards for the present.
          P(I,4)=0D0
          P(I,3)=0D0
        ENDIF
  390 CONTINUE
 
C...Reset colour processing information.
  400 DO 410 I=MINT(84)+1,N
        K(I,4)=MOD(K(I,4),MSTU(5)**2)
        K(I,5)=MOD(K(I,5),MSTU(5)**2)
  410 CONTINUE
 
      NCC=0
      DO 430 JS=1,2
C...If meson,  without gluon in BR, collapse q-qbar colour tags:
        IF (ITJUNC(JS).EQ.0) THEN
          JC1=MCT(JST(JS,1),1)
          JC2=MCT(JST(JS,2),2)
          NCC=NCC+1
          JCCO(NCC,1)=MAX(JC1,JC2)
          JCCO(NCC,2)=MIN(JC1,JC2)
C...Collapse colour tags in event record
          DO 420 I=MINT(84)+1,N
            IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
            IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
  420     CONTINUE
        ENDIF
  430 CONTINUE
 
  440 JS=1
      IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
      IF (NG(JS).GT.0) THEN
        NOPT=0
        RLOPT=1D9
C...Start at random gluon (optimizes speed for random attachments)
        NMGL=0
        IMGL=PYR(0)*NMI(JS)+1
  450   IMGL=MOD(IMGL,NMI(JS))+1
        NMGL=NMGL+1
C...Only loop through NMI once (with upper limit to save time)
        IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
          IGL  = IMI(JS,IMGL,1)
C...If not gluon or if already connected, try next.
          IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
     &         .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
C...Now loop through all possible insertions of this gluon.
          NMP1=0
          IMP1=PYR(0)*NMI(JS)+1
  460     IMP1=MOD(IMP1,NMI(JS))+1
          NMP1=NMP1+1
          IF (IMP1.EQ.IMGL) GOTO 460
C...Only loop through NMI once (with upper limit to save time).
          IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
            IP1  = IMI(JS,IMP1,1)
C...Try both colour mother and colour anti-mother.
C...Randomly select which one to try first.
            NANTI=0
            MANTI=PYR(0)*2
  470       MANTI=MOD(MANTI+1,2)
            NANTI=NANTI+1
            IF (NANTI.LE.2) THEN
              IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
C...Reject if no appropriate mother (or if mother is fictitious
C...parent gluon.)
              IF (IP2.LE.0) GOTO 470
              IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
C...Also reject if this link has already been tried.
              IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
              IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
C...Set flag to indicate that this link has now been tried for this
C...gluon. IP2 may be junction, which has several mothers.
              K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
              IF (K(IP2,2).NE.88) THEN
                K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
              ENDIF
 
C...JCG1: Original colour tag of gluon on IP1 side
C...JCG2: Original colour tag of gluon on IP2 side
C...JCP1: Original colour tag of IP1 on gluon side
C...JCP2: Original colour tag of IP2 on gluon side.
              JCG1=MCO(IGL,2-MANTI)
              JCG2=MCO(IGL,1+MANTI)
              JCP1=MCO(IP1,1+MANTI)
              JCP2=MCO(IP2,2-MANTI)
 
              CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
C...Reject gluon attachments that give rise to singlet gluons.
              IF (MACCPT.EQ.0) GOTO 470
 
C...Update colours
              JCG1=MCT(IGL,2-MANTI)
              JCG2=MCT(IGL,1+MANTI)
              JCP1=MCT(IP1,1+MANTI)
              JCP2=MCT(IP2,2-MANTI)
 
C...Select whether to accept this insertion
              IF (MSTP(89).EQ.0) THEN
C...Random insertions: no measure.
                RL=1D0
C...For random ordering, we want to suppress beam remnant breakups
C...already at this point.
                IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
     &               .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
                  NMP1=0
                  NMGL=0
                  GOTO 470
                ENDIF
              ELSEIF (MSTP(89).EQ.1) THEN
C...Rapidity ordering:
C...YGL = Rapidity of gluon.
                YGL=YMI(IMGL)
C...If fictitious gluon
                IF (YGL.EQ.100D0) THEN
                  YGL=(3-2*JS)*100D0
                  IDA1=MOD(K(IGL,4),MSTU(5))
                  IDA2=MOD(K(IGL,5),MSTU(5))
                  DO 480 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
                    IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
     &                   THEN
                      IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
                    ENDIF
  480             CONTINUE
                ENDIF
C...YP1 = Rapidity IP1
                YP1=YMI(IMP1)
C...If fictitious gluon
                IF (YP1.EQ.100D0) THEN
                  YP1=(3-2*JS)*YP1
                  IDA1=MOD(K(IP1,4),MSTU(5))
                  IDA2=MOD(K(IP1,5),MSTU(5))
                  DO 490 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
                    IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
     &                   THEN
                      IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
                    ENDIF
  490             CONTINUE
                ENDIF
C...YP2 = Rapidity of mother system
                IF (K(IP2,2).NE.88) THEN
                  DO 500 IMT=1,NMI(JS)
                    IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
  500             CONTINUE
C...If fictitious gluon
                  IF (YP2.EQ.100D0) THEN
                    YP2=(3-2*JS)*YP2
                    IDA1=MOD(K(IP2,4),MSTU(5))
                    IDA2=MOD(K(IP2,5),MSTU(5))
                    DO 510 IMT=1,NMI(JS)
C...Select (arbitrarily) the most central daughter.
                      IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
     &                     ) THEN
                        IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
                      ENDIF
  510               CONTINUE
                  ENDIF
C...Assign (arbitrarily) 100D0 to junction also
                ELSE
                  YP2=(3-2*JS)*100D0
                ENDIF
                RL=ABS(YGL-YP1)+ABS(YGL-YP2)
              ELSEIF (MSTP(89).EQ.2) THEN
C...Lambda ordering:
C...Compute lambda measure for this insertion.
                RL=1D0
                DO 520 IST=1,6
                  ISTR(IST)=0
  520           CONTINUE
C...If IP2 is junction, not caught below.
                IF (JCP2.EQ.0) THEN
                  ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
C...Anti-junction is colour endpoint et vv., always on JCG2.
                  ISTR(5-ITJU)=IP2
                ENDIF
                DO 530 I=MINT(84)+1,N
                  IF (K(I,1).LT.10) THEN
C...The new string pieces
                    IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
                    IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
                    IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
                    IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
                  ENDIF
  530           CONTINUE
C...Also identify junctions as string endpoints.
                DO 540 I=MINT(84)+1,N
                  ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
                  IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
C...Find partons adjacent to junctions.
                  IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
                    IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
     &                  .EQ.0) ISTR(2) = ICMO
                    IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
     &                  .EQ.0) ISTR(4) = ICMO
                  ENDIF
                  IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
                    IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
     &                  .EQ.0) ISTR(1) = IAMO
                    IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
     &                  .EQ.0) ISTR(3) = IAMO
                  ENDIF
  540           CONTINUE
C...The old string piece
                ISTR(5)=ISTR(1+2*MANTI)
                ISTR(6)=ISTR(4-2*MANTI)
                IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
     &              ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
C...If one or more of the colour tags for this connection is/are still
C...dangling, skip this attempt for the time being. 
                  RL=1D6
                ELSE
                  RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
     &                ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
                  RL=LOG(RL)
                ENDIF
              ENDIF
C...Allow some breadth to speed things up.
              IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
                NOPT=NOPT+1
              ELSEIF (RL.GT.RLOPT) THEN
                GOTO 470
              ELSE
                NOPT=1
                RLOPT=RL
              ENDIF
C...INSR(NOPT,1)=Gluon colour mother
C...INSR(NOPT,2)=Gluon
C...INSR(NOPT,3)=Gluon anticolour mother
              IF (NOPT.GT.1000) GOTO 470
              INSR(NOPT,1+2*MANTI)=IP2
              INSR(NOPT,2)=IGL
              INSR(NOPT,3-2*MANTI)=IP1
              IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
            ENDIF
            IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
          ENDIF
C...Reset link test information.
          DO 550 I=MINT(84)+1,N
            K(I,4)=MOD(K(I,4),MSTU(5)**2)
            K(I,5)=MOD(K(I,5),MSTU(5)**2)
  550     CONTINUE
          IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
        ENDIF
C...Now we have a list of best gluon insertions, none of which cause
C...singlets to arise. If list is empty, try again a few times. Note:
C...this should never happen if we have a meson with a gluon inserted
C...in the beam remnant, since that breaks up the colour line.
        IF (NOPT.EQ.0) THEN
C...Abandon BR-g-BR suppression for retries. This is not serious, it
C...just means we happened to start with trying a bad sequence.
          PARP80=1D0
          IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
     &         .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
            MRETRY=MRETRY+1
            DO 590 JS=1,2
              IF (ITJUNC(JS).NE.0) THEN
                JST(JS,1)=IV(JS,1)
                JST(JS,2)=IV(JS,2)
                JST(JS,3)=IV(JS,3)
C...Reset valence quark parent pointers
                DO 560 I=MINT(53)+1,N
                  IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
  560           CONTINUE
                MANTI=ITJUNC(JS)-1
C...Set (anti)colour mother = junction.
                DO 570 JV=1,3
                  K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
     &                 +MSTU(5)*IJU
  570           CONTINUE
              ELSE
C...Same for mesons. JST unchanged, so needn't be restored.
                IQ=JST(JS,1)
                IQBAR=JST(JS,2)
                K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
                K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
              ENDIF
C...Also reset gluon parent pointers.
              NG(JS)=0
              DO 580 IM=1,NMI(JS)
                I=IMI(JS,IM,1)
                IF (K(I,2).EQ.21) THEN
                  K(I,4)=MOD(K(I,4),MSTU(5))
                  K(I,5)=MOD(K(I,5),MSTU(5))
                  NG(JS)=NG(JS)+1
                ENDIF
  580         CONTINUE
  590       CONTINUE
C...Reset colour tags
            DO 600 I=MINT(84)+1,N
              MCT(I,1)=MCO(I,1)
              MCT(I,2)=MCO(I,2)
  600       CONTINUE
            GOTO 400
          ELSE
            IF(NERRPR.LT.5) THEN
              NERRPR=NERRPR+1
              CALL PYLIST(4)
              CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
              WRITE(MSTU(11),*) 'NG:', NG,'   MOUT:', MOUT(JS)
            ENDIF
C...Kill event and start another.
            MINT(51)=1
            RETURN
          ENDIF
        ELSE
C...Select between insertions, suppressing insertions wholly in the BR.
          IIN=PYR(0)*NOPT+1
  610     IIN=MOD(IIN,NOPT)+1
          IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
     &         .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
        ENDIF
 
C...Now we know which gluon to insert where. Colour tags in JCCO and
C...colour connection information should be updated, NG(JS) should be
C...counted down, and a new loop performed if there are still gluons
C...left on any side.
        ICM=INSR(IIN,1)
        IACM=INSR(IIN,3)
        IGL=INSR(IIN,2)
C...JCG : Original gluon colour tag
C...JCAG: Original gluon anticolour tag.
C...JCM : Original anticolour tag of gluon colour mother
C...JACM: Original colour tag of gluon anticolour mother
        JCG=MCO(IGL,1)
        JCM=MCO(ICM,2)
        JACG=MCO(IGL,2)
        JACM=MCO(IACM,1)
 
        CALL PYMIHG(JACM,JACG,JCM,JCG)
        IF (MACCPT.EQ.0) THEN
          IF(NERRPR.LT.5) THEN
            NERRPR=NERRPR+1
            CALL PYLIST(4)
            CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
            WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
          ENDIF
C...Kill event and start another.
          MINT(51)=1
          RETURN
        ELSE
C...If everything went fine, store new JCCN in JCCO.
          NCC=NCC+1
          DO 620 ICC=1,NCC
            JCCO(ICC,1)=JCCN(ICC,1)
            JCCO(ICC,2)=JCCN(ICC,2)
  620     CONTINUE
        ENDIF
 
C...One gluon attached is counted as equivalent to one end outside.
        MOUT(JS)=1
C...Set IGL colour mother = ICM.
        K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
C...Set ICM anticolour mother = IGL colour.
        IF (K(ICM,2).NE.88) THEN
          K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
        ELSE
C...If ICM is junction, just update JST array for now.
          DO 630 MSJ=1,3
            IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
  630     CONTINUE
        ENDIF
C...Set IGL anticolour mother = IACM.
        K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
C...Set IACM anticolour mother = IGL anticolour.
        IF (K(IACM,2).NE.88) THEN
          K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
        ELSE
C...If IACM is junction, just update JST array for now.
          DO 640 MSJ=1,3
            IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
  640     CONTINUE
        ENDIF
C...Count down # unconnected gluons.
        NG(JS)=NG(JS)-1
      ENDIF
      IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
 
      DO 840 JS=1,2
C...Collapse fictitious gluons.
        DO 670 IGL=MINT(53)+1,N
          IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
     &         K(IGL,1).EQ.14) THEN
            ICM=K(IGL,4)/MSTU(5)
            IAM=K(IGL,5)/MSTU(5)
            ICD=MOD(K(IGL,4),MSTU(5))
            IAD=MOD(K(IGL,5),MSTU(5))
C...Set gluon daughters pointing to gluon mothers
            K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
            K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
C...Set gluon mothers pointing to gluon daughters.
            IF (K(ICM,2).NE.88) THEN
              K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
            ELSE
C...Special case: mother=junction. Just update JST array for now.
              DO 650 MSJ=1,3
                IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
  650         CONTINUE
            ENDIF
            IF (K(IAM,2).NE.88) THEN
              K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
            ELSE
              DO 660 MSJ=1,3
                IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
  660         CONTINUE
            ENDIF
          ENDIF
  670   CONTINUE
 
C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
        IM=NMI(JS)+1
  680   IM=IM-1
        IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
        IF (IM.GT.MINT(31)) THEN
          NMI(JS)=NMI(JS)-1
          DO 690 IMR=IM,NMI(JS)
            IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
            IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
  690     CONTINUE
          GOTO 680
        ENDIF
 
C...Finally, connect junction.
        IF (ITJUNC(JS).NE.0) THEN
          DO 700 I=MINT(53)+1,N
            IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
  700     CONTINUE
C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
          NBRJQ =0
          NBRVQ =0
          DO 720 MSJ=1,3
            IDQ(MSJ)=0
C...Find jq with no glue inbetween inside beam remnant.
            IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
     &           THEN
              NBRJQ=NBRJQ+1
C...Set IDQ = -I if q non-valence and = +I if q valence.
              IDQ(NBRJQ)=-JST(JS,MSJ)
              DO 710 JV=1,3
                IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
                  IDQ(NBRJQ)=JST(JS,MSJ)
                  NBRVQ=NBRVQ+1
                ENDIF
  710         CONTINUE
            ENDIF
            I12=MOD(MSJ+1,2)
            I45=5
            IF (MSJ.EQ.3) I45=4
            K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
  720     CONTINUE
 
C...Check if diquark can be formed.
          IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
     &         .GE.1)) THEN
C...If there is less than 2 valence quarks connected to junction
C...and MSTP(88)>1, use random non-valence quarks to fill up.
            IF (NBRVQ.LE.1) THEN
              NDIQ=NBRVQ
  730         JFLIP=NBRJQ*PYR(0)+1
              IF (IDQ(JFLIP).LT.0) THEN
                IDQ(JFLIP)=-IDQ(JFLIP)
                NDIQ=NDIQ+1
              ENDIF
              IF (NDIQ.LE.1) GOTO 730
            ENDIF
C...Place selected quarks first in IDQ, ordered in flavour.
            DO 740 JDQ=1,3
              IF (IDQ(JDQ).LE.0) THEN
                ITEMP1  = IDQ(JDQ)
                IDQ(JDQ)= IDQ(3)
                IDQ(3)  = -ITEMP1
                IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
                  ITEMP1  = IDQ(1)
                  IDQ(1)  = IDQ(2)
                  IDQ(2)  = ITEMP1
                ENDIF
              ENDIF
  740       CONTINUE
C...Choose diquark spin.
            IF (NBRVQ.EQ.2) THEN
C...If the selected quarks are both valence, we may use SU(6) rules
C...to figure out which spin the diquark has, by a subdivision of the
C...original beam hadron into the selected diquark system plus a kicked
C...out quark, IKO.
              JKO=6
              DO 760 JDQ=1,2
                DO 750 JV=1,3
                  IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
  750           CONTINUE
  760         CONTINUE
              IKO=IV(JS,JKO)
              CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
            ELSE
C...If one or more of the selected quarks are not valence, we cannot use
C...SU(6) subdivisions of the original beam hadron. Instead, with the
C...flavours of the diquark already selected, we assume for now
C...50:50 spin-1:spin-0 (where spin-0 possible).
              KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
              IS=3
              IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
     &           (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
              KFDQ=KFDQ+ISIGN(IS,KFDQ)
            ENDIF
 
C...Collapse diquark-j-quark system to baryon, if allowed and possible.
C...Note: third quark can per definition not also be valence,
C...therefore we can only do this if we are allowed to use sea quarks.
  770       IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
              NTRY=0
  780         NTRY=NTRY+1
              CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
              IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
                GOTO 780
              ELSEIF(NTRY.GT.100) THEN
C...If no baryon can be found, give up and form diquark.
                IDQ(3)=0
                GOTO 770
              ELSE
C...Replace junction by baryon.
                K(IJU,1)=1
                K(IJU,2)=KFBAR
                K(IJU,3)=MINT(83)+JS
                K(IJU,4)=0
                K(IJU,5)=0
                P(IJU,5)=PYMASS(KFBAR)
                DO 790 MSJ=1,3
C...Prepare removal of participating quarks from ER.
                  K(JST(JS,MSJ),1)=-1
  790           CONTINUE
              ENDIF
            ELSE
C...If collapse to baryon not possible or not allowed, replace junction
C...by diquark. This way, collapsed gluons that were pointing at the
C...junction will now point (correctly) at diquark.
              MANTI=ITJUNC(JS)-1
              K(IJU,1)=3
              K(IJU,2)=KFDQ
              K(IJU,3)=MINT(83)+JS
              K(IJU,4)=0
              K(IJU,5)=0
              DO 800 MSJ=1,3
                IP=JST(JS,MSJ)
                IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
                  K(IJU,4+MANTI)=0
                  K(IJU,5-MANTI)=IP*MSTU(5)
                  K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
     &                 MSTU(5)*IJU
                  MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
                ELSE
C...Prepare removal of participating quarks from ER.
                  K(IP,1)=-1
                ENDIF
  800         CONTINUE
            ENDIF
 
C...Update so ER pointers to collapsed quarks
C...now go to collapsed object.
            DO 820 I=MINT(84)+1,N
              IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
     &             .K(I,1).GT.0) THEN
                DO 810 ISID=4,5
                  IMO=K(I,ISID)/MSTU(5)
                  IDA=MOD(K(I,ISID),MSTU(5))
                  IF (IMO.GT.0) THEN
                    IF (K(IMO,1).EQ.-1) IMO=IJU
                  ENDIF
                  IF (IDA.GT.0) THEN
                    IF (K(IDA,1).EQ.-1) IDA=IJU
                  ENDIF
                  K(I,ISID)=IDA+MSTU(5)*IMO
  810           CONTINUE
              ENDIF
  820       CONTINUE
          ENDIF
        ENDIF
 
C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
C...(this only happens for baryons, where we want to force the gluon
C...to sit next to the junction. Mesons handled above.)
        IF (NBRTOT(JS).EQ.0) THEN
          N=N+1
          DO 830 IX=1,5
            K(N,IX)=0
            P(N,IX)=0D0
            V(N,IX)=0D0
  830     CONTINUE
          IGL=N
          K(IGL,1)=3
          K(IGL,2)=21
          K(IGL,3)=MINT(83)+JS
          IF (ITJUNC(JS).NE.0) THEN
C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
            JLEG=PYR(0)*NVSUM(JS)+1
            I1=JST(JS,JLEG)
            JST(JS,JLEG)=IGL
            JCT=MCT(I1,ITJUNC(JS))
            MCT(IGL,3-ITJUNC(JS))=JCT
            NCT=NCT+1
            MCT(IGL,ITJUNC(JS))=NCT
            MANTI=ITJUNC(JS)-1
          ELSE
C...Meson. Should not happen.
            CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
            IF(NERRPR.LT.5) THEN
              WRITE(MSTU(11),*) 'This should not have been possible!'
              CALL PYLIST(4)
              NERRPR=NERRPR+1
            ENDIF
            MINT(51)=1
            RETURN
          ENDIF
          I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
          K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
          K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
          K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
          IF (K(I2,2).NE.88) THEN
            K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
          ELSE
            IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
              K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
            ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
              K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
            ELSE
              K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
            ENDIF
          ENDIF
        ENDIF
  840 CONTINUE
 
C...Remove collapsed quarks and junctions from ER and update IMI.
      CALL PYEDIT(11)
 
C...Also update beam remnant part of IMI.
      NMI(1)=MINT(31)
      NMI(2)=MINT(31)
      DO 850 I=MINT(53)+1,N
        IF (K(I,1).LE.0) GOTO 850
C...Restore BR quark/diquark/baryon pointers in IMI.
        IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
          JS=K(I,3)-MINT(83)
          NMI(JS)=NMI(JS)+1
          IMI(JS,NMI(JS),1)=I
          IMI(JS,NMI(JS),2)=0
        ENDIF
  850 CONTINUE
 
C...Restore companion information from collapsed gluons.
      DO 870 I=MINT(53)+1,N
        IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
          JS=K(I,3)-MINT(83)
          JCD=MOD(K(I,4),MSTU(5))
          JAD=MOD(K(I,5),MSTU(5))
          DO 860 IM=1,NMI(JS)
            IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
            IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
  860     CONTINUE
          IMI(JS,IMC,2)=IMI(JS,IMA,1)
          IMI(JS,IMA,2)=IMI(JS,IMC,1)
        ENDIF
  870 CONTINUE
 
C...Renumber colour lines (since some have disappeared)
      JCT=0
      JCD=0
  880 JCT=JCT+1
      MFOUND=0
      I=MINT(84)
  890 I=I+1
      IF (I.EQ.N+1) THEN
        IF (MFOUND.EQ.0) JCD=JCD+1
      ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
        MCT(I,1)=JCT-JCD
        MFOUND=1
      ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
        MCT(I,2)=JCT-JCD
        MFOUND=1
      ENDIF
      IF (I.LE.N) GOTO 890
      IF (JCT.LT.NCT) GOTO 880
      NCT=JCT-JCD
 
C...Reset hard interaction subsystems to their CM frames.
      IF (IBOOST.EQ.1) THEN
        DO 900 IM=1,MINT(31)
          BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
          CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
  900   CONTINUE
C...Zero beam remnant longitudinal momenta and energies
        DO 910 I=MINT(53)+1,N
          P(I,3)=0D0
          P(I,4)=0D0
  910   CONTINUE
      ELSE
        CALL PYERRM(9
     &       ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
C...Kill event and start another.
        MINT(51)=1
        RETURN
      ENDIF
 
 9999 RETURN
      END
C*********************************************************************
 
C...PYCTTR
C...Adapted from PYPREP.
C...Assigns LHA1 colour tags to coloured partons based on
C...K(I,4) and K(I,5) colour connection record.
C...KCS negative signifies that a previous tracing should be continued.
C...(in case the tag to be continued is empty, the routine exits)
C...Starts at I and ends at I or IEND.
C...Special considerations for systems with junctions.
C...Special: if IEND=-1, means trace this parton to its color partner,
C...         then exit. If no partner found, exit with 0. 

      SUBROUTINE PYCTTR(I,KCS,IEND)
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/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
      COMMON/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
      DATA NERRPR/0/
      SAVE NERRPR
 
C...Skip if parton not existing or does not have KCS
      IF (K(I,1).LE.0) GOTO 120
      KC=PYCOMP(K(I,2))
      IF (KC.EQ.0) GOTO 120
      KQ=KCHG(KC,2)
      IF (KQ.EQ.0) GOTO 120
      IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) 
     &    GOTO 120
 
      IF (KCS.GT.0) THEN
        NCT=NCT+1
C...Set colour tag of first parton.
        MCT(I,KCS-3)=NCT
        NCS=NCT
      ELSE
        KCS=-KCS
        NCS=MCT(I,KCS-3)
        IF (NCS.EQ.0) GOTO 120
      ENDIF
 
      IA=I
      NSTP=0
  100 NSTP=NSTP+1
      IF(NSTP.GT.4*N) THEN
        CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
        GOTO 120
      ENDIF
 
C...Finished if reached final-state triplet.
      IF(K(IA,1).EQ.3) THEN
        IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
      ENDIF
 
C...Also finished if reached junction.
      IF(K(IA,1).EQ.42) THEN
        GOTO 120
      ENDIF
 
C...GOTO next parton in colour space.
  110 IB=IA
C...If IB's KCS daughter not traced and exists, goto KCS daughter.
      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
C...If KCS mother traced or KCS mother nonexistent, switch colour.
        IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
     &       MSTU(5)).EQ.0) THEN
          KCS=9-KCS
          NCT=NCT+1
          NCS=NCT
C...Assign new colour tag on other side of old parton.
          MCT(IB,KCS-3)=NCT
        ENDIF
C...Goto (new) KCS mother, set mother traced tag
        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
        IF (IEND.EQ.-1) THEN
          IEND=0
          GOTO 120
        ENDIF
        CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
        IF(NERRPR.LT.5) THEN
          write(*,*) 'began at ',I
          write(*,*) 'ended going from', IB, ' to', IA, '  KCS=',KCS,
     &        '  NCS=',NCS,'  MREV=',MREV
          CALL PYLIST(4)
          NERRPR=NERRPR+1
        ENDIF
        MINT(51)=1
        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
C...Set KSC mother traced tag for IA
        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
C...Set KCS daughter traced tag for IA
        K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
      ENDIF
C...Assign new colour tag
      MCT(IA,KCS-3)=NCS
C...Finish if IEND=-1 and found final-state color partner 
      IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
        IEND=IA
        GOTO 120        
      ENDIF
      IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
 
  120 RETURN
      END
 
*********************************************************************
 
C...PYMIHG
C...Collapse JCP1 and connecting tags to JCG1.
C...Collapse JCP2 and connecting tags to JCG2.
 
      SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...The event record
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
C...Parameters
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYJETS/,/PYINT1/
C...Local variables
      COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
      COMMON /PYCTAG/NCT,MCT(4000,2)
      SAVE /PYCBLS/,/PYCTAG/
 
C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
C...in temporary tag collapse array JCCN. Only break up one connection.
      MACCPT=1
      MCLPS=0
      DO 100 ICC=1,NCC
        JCCN(ICC,1)=JCCO(ICC,1)
        JCCN(ICC,2)=JCCO(ICC,2)
C...If there was a mother, it was previously connected to JCP1.
C...Should be changed to JCP2.
        IF (MCLPS.EQ.0) THEN
          IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
     &         ,JCP2)) THEN
            JCCN(ICC,1)=MAX(JCG2,JCP2)
            JCCN(ICC,2)=MIN(JCG2,JCP2)
            MCLPS=1
          ENDIF
        ENDIF
  100 CONTINUE
C...Also collapse colours on JCP1 side of JCG1
      IF (JCP1.NE.0) THEN
        JCCN(NCC+1,1)=MAX(JCP1,JCG1)
        JCCN(NCC+1,2)=MIN(JCP1,JCG1)
      ELSE
        JCCN(NCC+1,1)=MAX(JCP2,JCG2)
        JCCN(NCC+1,2)=MIN(JCP2,JCG2)
      ENDIF
 
C...Initialize event record colour tag array MCT array to MCO.
       DO 110 I=MINT(84)+1,N
        MCT(I,1)=MCO(I,1)
        MCT(I,2)=MCO(I,2)
  110 CONTINUE
 
C...Collapse tags:
C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
      DO 160 IS=1,4
C...Skip if junction.
        IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
C...Define starting point in tag space.
C...JCA = previous tag
C...JCO = present tag
C...JCN = new tag
        IF (MOD(IS,2).EQ.1) THEN
          JCO=JCP1
          JCN=JCG1
          JCALL=JCG1
        ELSEIF (MOD(IS,2).EQ.0) THEN
          JCO=JCP2
          JCN=JCG2
          JCALL=JCG2
        ENDIF
        ITRACE=0
  120   ITRACE=ITRACE+1
        IF (ITRACE.GT.1000) THEN
C...NB: Proper error message should be defined here.
          CALL PYERRM(14
     &         ,'(PYMIHG:) Inf loop when collapsing colours.')
          MINT(57)=MINT(57)+1
          MINT(51)=1
          RETURN
        ENDIF
C...Collapse all JCN tags to JCALL
        DO 130 I=MINT(84)+1,N
          IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
          IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
  130   CONTINUE
C...IS = 1,2: first step forward. IS = 3,4: first step backward.
        IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
          JCA=JCN
          JCN=JCO
        ELSE
          JCA=JCO
          JCO=JCN
        ENDIF
C...If possible, step from JCO to new tag JCN not equal to JCA.
        DO 140 ICC=1,NCC+1
          IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
     &         JCCN(ICC,2)
          IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
     &         JCCN(ICC,1)
  140   CONTINUE
C...Iterate if new colour was arrived at, but don't go in circles.
        IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
C...Change all JCN tags in MCO to JCALL in MCT.
        DO 150 I=MINT(84)+1,N
          IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
          IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
C...If gluon and colour tag = anticolour tag (and not = 0) try again.
          IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
     &         .NE.0) MACCPT=0
  150   CONTINUE
  160 CONTINUE
 
      DO 200 JCL=NCT,1,-1
        JCA=0
        JCN=JCL
  170   JCO=JCN
        DO 180 ICC=1,NCC+1
          IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
     &         =JCCN(ICC,2)
          IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
     &         =JCCN(ICC,1)
  180   CONTINUE
C...Overpaint all JCN with JCL
        IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
          DO 190 I=MINT(84)+1,N
            IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
            IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
C...If gluon and colour tag = anticolour tag (and not = 0) try again.
            IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
     &           .NE.0) MACCPT=0
  190     CONTINUE
          JCA=JCO
          GOTO 170
        ENDIF
  200 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMIRM
C...Picks primordial kT and shares longitudinal momentum among
C...beam remnants.
 
      SUBROUTINE PYMIRM
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...The event record
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
C...Parameters
      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)
C...The common block of colour tags.
      COMMON/PYCTAG/NCT,MCT(4000,2)
C...The common block of dangling ends
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
C...Local variables
      DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
C...W(I,J)|  J=0    |   1   |   2   |
C...  I=0 | Wrem**2 |  W+   |  W-   |
C...    1 | W1**2   |  W1+  |  W1-  |
C...    2 | W2**2   |  W2+  |  W2-  |
C...4-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...Tentative parametrization of <kT> as a function of Q.
      SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
C      SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
C      SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
      GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
C...Lambda kinematic function.
      FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
 
C...Beginning and end of beam remnant partons
      NOUT=MINT(53)
      ISUB=MINT(1)
 
C...Loopback point if kinematic choices gives impossible configuration.
      NTRY=0
  100 NTRY=NTRY+1
 
C...Assign kT values on each side separately.
      DO 180 JS=1,2
 
C...First zero all kT on this side. Skip if no kT to generate.
        DO 110 IM=1,NMI(JS)
          P(IMI(JS,IM,1),1)=0D0
          P(IMI(JS,IM,1),2)=0D0
  110   CONTINUE
        IF(MSTP(91).LE.0) GOTO 180
 
C...Now assign kT to each (non-collapsed) parton in IMI.
        DO 170 IM=1,NMI(JS)
          I=IMI(JS,IM,1)
C...Select kT according to truncated gaussian or 1/kt6 tails.
C...For first interaction, either use rms width = PARP(91) or fitted.
          IF (IM.EQ.1) THEN
            SIGMA=PARP(91)
            IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
              Q=SQRT(PT2MI(IM))
              SIGMA=SIGPT(Q)
            ENDIF
          ELSE
C...For subsequent interactions and BR partons use fragmentation width.
            SIGMA=PARJ(21)
          ENDIF
          PHI=PARU(2)*PYR(0)
          PT=0D0
          IF(NTRY.LE.100) THEN
 111        IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
              PT=GETPT(Q,SIGMA)
              PTX=PT*COS(PHI)
              PTY=PT*SIN(PHI)
            ELSEIF (MSTP(91).EQ.2) THEN
              CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
     &          'available, using MSTP(91)=1.')
              CALL PYGIVE('MSTP(91)=1')
              GOTO 111
            ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
C...Use distribution with kt**6 tails, rms width = PARP(91).
              EPS=SQRT(3D0/2D0)*SIGMA
C...Generate PTX and PTY separately, each propto 1/KT**6
              DO 119 IXY=1,2
C...Decide which interval to try
 112            P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
                IF (PYR(0).LT.P12) THEN
C...Use flat approx with accept/reject up to EPS.
                  PT=PYR(0)*EPS
                  WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
                  IF (PYR(0).GT.WT) GOTO 112
                ELSE
C...Above EPS, use 1/kt**6 approx with accept/reject.
                  PT=EPS/(PYR(0)**(1D0/5D0))
                  WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
                  IF (PYR(0).GT.WT) GOTO 112
                ENDIF
                MSIGN=1
                IF (PYR(0).GT.0.5D0) MSIGN=-1
                IF (IXY.EQ.1) PTX=MSIGN*PT
                IF (IXY.EQ.2) PTY=MSIGN*PT
 119          CONTINUE
            ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
              PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
              PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
            ENDIF
C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
            PT=SQRT(PTX**2+PTY**2)
            WT=1D0
            IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
            IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
            PTX=PTX*WT
            PTY=PTY*WT
            PT=SQRT(PTX**2+PTY**2)
          ENDIF
 
          P(I,1)=P(I,1)+PTX
          P(I,2)=P(I,2)+PTY
 
C...Compensation kicks, with varying degree of local anticorrelations.
          MCORR=MSTP(90)
          IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
            PTCX=-PTX/(NMI(JS)-1)
            PTCY=-PTY/(NMI(JS)-1)
            IF(ISUB.EQ.95) THEN
              PTCX=-PTX/(NMI(JS)-2)
              PTCY=-PTY/(NMI(JS)-2)
            ENDIF
            DO 120 IMC=1,NMI(JS)
              IF (IMC.EQ.IM) GOTO 120
              IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
              P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
              P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
  120       CONTINUE
          ELSEIF (MCORR.GE.1) THEN
            DO 140 MSID=4,5
              NNXT(MSID-3)=0
C...Count up # of neighbours on either side
              IMO=I
  130         IMO=K(IMO,MSID)/MSTU(5)
              IF (IMO.EQ.0) GOTO 140
              NNXT(MSID-3)=NNXT(MSID-3)+1
C...Stop at quarks and junctions
              IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
  140       CONTINUE
C...How should compensation be shared when unequal numbers on the
C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
            NSUM=NNXT(1)+NNXT(2)
            T1=0
            DO 160 MSID=4,5
C...Total momentum to be compensated on this side
              IF (NNXT(MSID-3).EQ.0) GOTO 160
              PTCX=-(NNXT(MSID-3)*PTX)/NSUM
              PTCY=-(NNXT(MSID-3)*PTY)/NSUM
C...RS: compensation supression factor as we go out from parton I.
C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
C...since (for now) MSTP(90) provides enough variability.
              RS=0.5D0
              FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
              IMO=I
  150         IDA=IMO
              IMO=K(IMO,MSID)/MSTU(5)
              IF (IMO.EQ.0) GOTO 160
              FAC=FAC*RS
              IF (K(IMO,2).NE.88) THEN
                P(IMO,1)=P(IMO,1)+FAC*PTCX
                P(IMO,2)=P(IMO,2)+FAC*PTCY
                IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
C...If we reach junction, divide out the kT that would have been
C...assigned to the junction on each of its other legs.
              ELSE
                L1=MOD(K(IMO,4),MSTU(5))
                L2=K(IMO,5)/MSTU(5)
                L3=MOD(K(IMO,5),MSTU(5))
                P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
                P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
                P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
                P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
                P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
                P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
                P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
                P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
              ENDIF
 
  160       CONTINUE
          ENDIF
  170   CONTINUE
C...End assignment of kT values to initiators and remnants.
  180 CONTINUE
 
C...Check kinematics constraints for non-BR partons.
      DO 190 IM=1,MINT(31)
        SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
        PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
        PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
        PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
     &        +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
        IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
          IF(NTRY.GE.100) THEN
C...Kill this event and start another.
            CALL PYERRM(1,
     &           '(PYMIRM:) No consistent (x,kT) sets found')
            MINT(51)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
  190 CONTINUE
 
C...Calculate W+ and W- available for combined remnant system.
      W(0,1)=VINT(1)
      W(0,2)=VINT(1)
      DO 200 IM=1,MINT(31)
        PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
     &       +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
        ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
        W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
        W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
  200 CONTINUE
C...Also store Wrem**2 = W+ * W-
      W(0,0)=W(0,1)*W(0,2)
 
      IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
          IF(NTRY.GE.100) THEN
C...Kill this event and start another.
            CALL PYERRM(1,
     &    '(PYMIRM:) Negative beam remnant mass squared unavoidable')
            MINT(51)=1
            RETURN
          ENDIF
          GOTO 100
      ENDIF

C...Assign unscaled x values to partons/hadrons in each of the
C...beam remnants and calculate unscaled W+ and W- from them.
      NTRYX=0
  210 NTRYX=NTRYX+1
      DO 280 JS=1,2
        W(JS,1)=0D0
        W(JS,2)=0D0
        DO 270 IM=MINT(31)+1,NMI(JS)
          I=IMI(JS,IM,1)
          KF=K(I,2)
          KFA=IABS(KF)
          ICOMP=IMI(JS,IM,2)
 
C...Skip collapsed gluons and junctions. Reset.
          IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
          IF (KFA.EQ.88) GOTO 270
          X=0D0
          IVALQ(1)=0
          IVALQ(2)=0
          ICOMQ(1)=0
          ICOMQ(2)=0
 
C...If gluon then only beam remnant, so takes all.
          IF(KFA.EQ.21) THEN
            X=1D0
C...If valence quark then use parametrized valence distribution.
          ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
            IVALQ(1)=KF
C...If companion quark then derive from companion x.
          ELSEIF(KFA.LE.6) THEN
            ICOMQ(1)=ICOMP
C...If valence diquark then use two parametrized valence distributions.
          ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
     &    ICOMP.EQ.0) THEN
            IVALQ(1)=ISIGN(KFA/1000,KF)
            IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
C...If valence+sea diquark then combine valence + companion choices.
          ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
     &    ICOMP.LT.MSTU(5)) THEN
            IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
              IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
            ELSE
              IVALQ(1)=ISIGN(KFA/1000,KF)
            ENDIF
            ICOMQ(1)=ICOMP
C...Extra code: workaround for diquark made out of two sea
C...quarks, but where not (yet) ICOMP > MSTU(5).
            DO 220 IM1=1,MINT(31)
              IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
                ICOMQ(2)=IMI(JS,IM1,1)
                IVALQ(1)=0
              ENDIF
  220       CONTINUE
C...If sea diquark then sum of two derived from companion x.
          ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
             ICOMQ(1)=MOD(ICOMP,MSTU(5))
             ICOMQ(2)=ICOMP/MSTU(5)
C...If meson or baryon then use fragmentation function.
C...Somewhat arbitrary split into old and new flavour, but OK normally.
          ELSE
            KFL3=MOD(KFA/10,10)
            IF(MOD(KFA/1000,10).EQ.0) THEN
              KFL1=MOD(KFA/100,10)
            ELSE
              KFL1=MOD(KFA,10000)-10*KFL3-1
              IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
     &        MOD(KFA,10).EQ.2) KFL1=KFL1+2
            ENDIF
            PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
            CALL PYZDIS(KFL1,KFL3,PR,X)
          ENDIF
 
          DO 260 IQ=1,2
C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
C...In other baryons combine u and d from proton appropriately.
            IF(IVALQ(IQ).NE.0) THEN
              NVAL=0
              IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
              IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
              IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
C...Meson.
              IF(KFIVAL(JS,3).EQ.0) THEN
                MDU=0
C...Baryon with three identical quarks: mix u and d forms.
              ELSEIF(NVAL.EQ.3) THEN
                MDU=INT(PYR(0)+5D0/3D0)
C...Baryon, one of two identical quarks: u form.
              ELSEIF(NVAL.EQ.2) THEN
                MDU=2
C...Baryon with two identical quarks, but not the one picked: d form.
              ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
     &        KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
                MDU=1
C...Baryon with three nonidentical quarks: mix u and d forms.
              ELSE
                MDU=INT(PYR(0)+5D0/3D0)
              ENDIF
              XPOW=0.8D0
              IF(MDU.EQ.1) XPOW=3.5D0
              IF(MDU.EQ.2) XPOW=2D0
  230         XX=PYR(0)**2
              IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
              X=X+XX
            ENDIF
 
C...Calculation of x of companion quark.
            IF(ICOMQ(IQ).NE.0) THEN
              XCOMP=1D-4
              DO 240 IM1=1,MINT(31)
                IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
  240         CONTINUE
              NPOW=MAX(0,MIN(4,MSTP(87)))
  250         XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
              CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
     &        (XCOMP**2+XX**2)/(XCOMP+XX)**2
              IF(CORR.LT.PYR(0)) GOTO 250
              X=X+XX
            ENDIF
  260     CONTINUE
 
C...Optionally enchance x of composite systems (e.g. diquarks)
          IF (KFA.GT.100) X=PARP(79)*X
 
C...Store x. Also calculate light cone energies of each system.
          XMI(JS,IM)=X
          W(JS,JS)=W(JS,JS)+X
          W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
  270   CONTINUE
        W(JS,JS)=W(JS,JS)*W(0,JS)
        W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
        W(JS,0)=W(JS,1)*W(JS,2)
  280 CONTINUE
 
C...Check W1 W2 < Wrem (can be done before rescaling, since W
C...insensitive to global rescalings of the BR x values).
      IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
     &     THEN
        GOTO 210
      ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
        GOTO 100
      ELSEIF (NTRYX.GT.100) THEN
        CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
        MINT(57)=MINT(57)+1
        MINT(51)=1
        RETURN
      ENDIF
 
C...Compute x rescaling factors
      COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
      R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
      R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
 
      IF (R1.LT.0.OR.R2.LT.0) THEN
        CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
        MINT(57)=MINT(57)+1
        MINT(51)=1
      ENDIF
 
C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
      W(1,1)=W(1,1)*R1
      W(1,2)=W(1,2)/R1
      W(2,1)=W(2,1)/R2
      W(2,2)=W(2,2)*R2
 
C...Rescale BR x values.
      DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
        XMI(1,IM)=XMI(1,IM)*R1
        XMI(2,IM)=XMI(2,IM)*R2
  290 CONTINUE
 
C...Now we have a consistent set of x and kT values.
C...First set up the initiators and their daughters correctly.
      DO 300 IM=1,MINT(31)
        I1=IMI(1,IM,1)
        I2=IMI(2,IM,1)
        ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
     &       (P(I1,2)+P(I2,2))**2
        PT12=P(I1,1)**2+P(I1,2)**2
        PT22=P(I2,1)**2+P(I2,2)**2
C...p_z
        P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
        P(I2,3)=-P(I1,3)
C...Energies (masses should be zero at this stage)
        P(I1,4)=SQRT(PT12+P(I1,3)**2)
        P(I2,4)=SQRT(PT22+P(I2,3)**2)
 
C...Transverse 12 system initiator velocity:
        VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
        VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
C...Boost to overall initiator system rest frame
        CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
        CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)

C...Compute phi,theta coordinates of I1 and rotate z axis.
        PHI=PYANGL(P(I1,1),P(I1,2))
        THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
        IMIN=IMISEP(IM-1)+1
C...(include documentation lines if MI = 1)
        IF (IM.EQ.1) IMIN=MINT(83)+5
        IMAX=IMISEP(IM)
C...Rotate entire system in phi
        CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
C...Only rotate 12 system in theta
        CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
        CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)

C...Now boost entire system back to LAB
        VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
        CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
        CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))

  300 CONTINUE
 
 
C...For the beam remnant partons/hadrons, we only need to set pz and E.
      DO 320 JS=1,2
        DO 310 IM=MINT(31)+1,NMI(JS)
          I=IMI(JS,IM,1)
C...Skip collapsed gluons and junctions.
          IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
          IF (KFA.EQ.88) GOTO 310
          RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
          P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
          P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
          IF (JS.EQ.2) P(I,3)=-P(I,3)
  310   CONTINUE
  320 CONTINUE
 
 
C...Documentation lines
      DO 340 JS=1,2
        IN=MINT(83)+JS+2
        IO=IMI(JS,1,1)
        K(IN,1)=21
        K(IN,2)=K(IO,2)
        K(IN,3)=MINT(83)+JS
        K(IN,4)=0
        K(IN,5)=0
        DO 330 J=1,5
          P(IN,J)=P(IO,J)
          V(IN,J)=V(IO,J)
  330   CONTINUE
        MCT(IN,1)=MCT(IO,1)
        MCT(IN,2)=MCT(IO,2)
  340 CONTINUE
 
C...Final state colour reconnections.
      IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
 
C...Number of colour tags for which a recoupling will be tried.
      NTOT=NCT
C...Number of recouplings to try
      MINT(34)=0
      NRECP=0
      NITER=0
  350 NRECP=MINT(34)
      NITER=NITER+1
      IITER=0
  360 IITER=IITER+1
      IF (IITER.LE.PARP(78)*NTOT) THEN
C...Select two colour tags at random
C...NB: jj strings do not have colour tags assigned to them,
C...thus they are as yet not affected by anything done here.
        JCT=PYR(0)*NCT+1
        KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
        IJ1=0
        IJ2=0
        IK1=0
        IK2=0
C...Find final state partons with this (anti)colour
        DO 370 I=MINT(84)+1,N
          IF (K(I,1).EQ.3) THEN
            IF (MCT(I,1).EQ.JCT) IJ1=I
            IF (MCT(I,2).EQ.JCT) IJ2=I
            IF (MCT(I,1).EQ.KCT) IK1=I
            IF (MCT(I,2).EQ.KCT) IK2=I
          ENDIF
  370   CONTINUE
C...Only consider recouplings not involving junctions for now.
        IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
 
        RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
        RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
        IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
          MCT(IJ2,2)=KCT
          MCT(IK2,2)=JCT
C...Count up number of reconnections
          MINT(34)=MINT(34)+1
        ENDIF
        IF (MINT(34).LE.1000) THEN
          GOTO 360
        ELSE
          CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
          GOTO 380
        ENDIF
      ENDIF
      IF (NRECP.LT.MINT(34)) GOTO 350
 
C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
  380 MINT(33)=1
 
      RETURN
      END

C*********************************************************************
 
C...PYFSCR
C...Performs colour annealing.
C...MSTP(95) : CR Type
C...         = 1  : old cut-and-paste reconnections, handled in PYMIHK
C...         = 2  : Type I(no gg loops); hadron-hadron only
C...         = 3  : Type I(no gg loops); all beams
C...         = 4  : Type II(gg loops)  ; hadron-hadron only
C...         = 5  : Type II(gg loops)  ; all beams
C...         = 6  : Type S             ; hadron-hadron only
C...         = 7  : Type S             ; all beams
C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
C...Type S is driven by starting only from free triplets, not octets.
C...A string piece remains unchanged with probability
C...    PKEEP = (1-PARP(78))**N
C...This scaling corresponds to each string piece having to go through
C...N other ones, each with probability PARP(78) for reconnection, where
C...N is here chosen simply as the number of multiple interactions,
C...for a rough scaling with the general level of activity.
 
      SUBROUTINE PYFSCR(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/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
      COMMON/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
     &/PYPARS/
C...MCN: Temporary storage of new colour tags
      INTEGER MCN(4000,2)
C...Arrays for storing color string lengths
      INTEGER ICR(4000),MSCR(4000)
      INTEGER IOPT(4000)
      DOUBLE PRECISION RLOPTC(4000)
 
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...Check valid range of MSTP(95), local copy
      IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
      MSTP95=MOD(MSTP(95),10)
C...Set whether CR allowed inside resonance systems or not
C...(not implemented yet)
C      MRESCR=1
C      IF (MSTP(95).GE.10) MRESCR=0
 
C...Check whether colour tags already defined
      IF (MINT(33).EQ.0) THEN
C...Erase any existing colour tags for this event
        DO 100 I=1,N
          MCT(I,1)=0
          MCT(I,2)=0
 100    CONTINUE
C...Create colour tags for this event
        DO 120 I=1,N
          IF (K(I,1).EQ.3) THEN
            DO 110 KCS=4,5
              KCSIN=KCS
              IF (MCT(I,KCSIN-3).EQ.0) THEN
                CALL PYCTTR(I,KCSIN,I)
              ENDIF
 110        CONTINUE
          ENDIF
 120    CONTINUE
C...Instruct PYPREP to use colour tags
        MINT(33)=1
      ENDIF
 
C...For MSTP(95) even, only apply to hadron-hadron
      KA1=IABS(MINT(11))
      KA2=IABS(MINT(12))
      IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
 
C...Initialize new tag array (but do not delete old yet)
      LCT=NCT
      DO 130 I=MAX(1,IP),N
         MCN(I,1)=0
         MCN(I,2)=0
  130 CONTINUE
 
C...For each final-state dipole, check whether string should be
C...preserved.
      NCR=0
      IA=0
      IC=0
      
      DO 150 ICT=1,NCT
        IA=0
        IC=0
        DO 140 I=MAX(1,IP),N
          IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
          IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
  140   CONTINUE
        IF (IC.NE.0.AND.IA.NE.0) THEN
          CRMODF=1D0
C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
C...(so far ignores the possibility that the whole "muck" may be moving.)
          IF (PARP(77).GT.0D0) THEN
            PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
            IF (KA1.LT.100.AND.KA2.LT.100) THEN
              P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
            ELSE
              P2STR = 3D0/2D0 * PT2STR
            ENDIF
            RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
            RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
C...Estimate number of particles ~ log(M2), cut off at 1.
            RLOGM2=MAX(1D0,LOG(RM2STR))
            P2AVG=P2STR/RLOGM2
C...Supress reconnection probability by 1/(1+P77*P2AVG)
            CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
          ENDIF
          PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
          IF (PYR(0).LE.PKEEP) THEN
            LCT=LCT+1
            MCN(IC,1)=LCT
            MCN(IA,2)=LCT
          ELSE
C...Add coloured parton
            NCR=NCR+1
            ICR(NCR)=IC
            MSCR(NCR)=1
            IOPT(NCR)=0
            RLOPTC(NCR)=1D19
C...Add anti-coloured parton
            NCR=NCR+1
            ICR(NCR)=IA   
            MSCR(NCR)=2
            IOPT(NCR)=0
            RLOPTC(NCR)=1D19
          ENDIF
        ENDIF
  150 CONTINUE
 
C...Skip if there is only one possibility
      IF (NCR.LE.2) THEN
        GOTO 9999
      ENDIF

C...Reorder, so ordered in I (in order to correspond to old algorithm)
      NLOOP=0
 151  NLOOP=NLOOP+1
      MORD=1
      DO 155 IC1=1,NCR-1
        I1=ICR(IC1)
        I2=ICR(IC1+1)
        IF (I1.GT.I2) THEN
          IT=I1
          MST=MSCR(IC1)
          ICR(IC1)=I2
          MSCR(IC1)=MSCR(IC1+1)
          ICR(IC1+1)=IT
          MSCR(IC1+1)=MST
          MORD=0
        ENDIF
 155  CONTINUE
C...Max do 1000 reordering loops
      IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151

C...Loop over CR partons
C...(Ignore junctions for now.)
      NLOOP=0
  160 NLOOP=NLOOP+1
      RLMAX=0D0
      ICRMAX=0
C...Loop over coloured partons
      DO 230 IC1=1,NCR
C...Retrieve parton Event Record index and Colour Side
        I=ICR(IC1)
        MSI=MSCR(IC1)
C...Skip already connected partons        
        IF (MCN(I,MSI).NE.0) GOTO 230
C...Shorthand for colour charge
        MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
C...For Seattle algorithm, only start from partons with one dangling
C...colour tag
        IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
          IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
        ENDIF
C...Retrieve saved optimal partner                
        IO=IOPT(IC1) 
        IF (IO.NE.0) THEN 
C...Reject saved optimal partner if latter is now connected
C...(Also reject if using model S1, since saved partner may
C...now give rise to gg loop.)
          IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
            IOPT(IC1)=0
            RLOPTC(IC1)=1D19
          ENDIF
        ENDIF
        RLOPT=RLOPTC(IC1)
C...Search for new optimal partner if necessary
        IF (IOPT(IC1).EQ.0) THEN
          MBROPT=0
          MGGOPT=0
          RLOPT=1D19
C...Loop over partons you can connect to
          DO 210 IC2=1,NCR
            J=ICR(IC2)
            MSJ=MSCR(IC2)
C...Skip if already connected
            IF (MCN(J,MSJ).NE.0) GOTO 210
C...Skip if this not colour-anticolour pair
            IF (MSI.EQ.MSJ) GOTO 210          
C...And do not let gluons connect to themselves
            IF (I.EQ.J) GOTO 210
C...Suppress direct connections between partons in same Beam Remnant
            MBRSTR=0
            IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
     &          MBRSTR=1
C...Shorthand for colour charge
            MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
C...Check for gluon loops
            MGGSTR=0
            IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
              IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
     &            MCN(I,2).NE.0) MGGSTR=1
            ENDIF
C...Save connection with smallest lambda measure
            RL=FOUR(I,J)
C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
            IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
              IF (K(I,2).EQ.21) RL=0.5D0*RL
              IF (K(J,2).EQ.21) RL=0.5D0*RL
            ENDIF
C...If best so far was a BR string and this is not, also save.
C...If best so far was a gg string and this is not, also save.
C...NB: this is not fool-proof. If the algorithm finds a BR or gg
C...string with a small Lambda measure as the last step, this connection
C...will be saved regardless of whether other possibilities existed.
C...I.e., there should really be a check whether another possibility has
C...already been found, but since these models are now actively in use
C...and uncertainties are anyway large, the algorithm is left as it is. 
C...(correction --> Pythia 8 ?)
            IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
     &          .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
     &          .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
              RLOPT=RL
              RLOPTC(IC1)=RLOPT
              IOPT(IC1)=J
              MBROPT=MBRSTR
              MGGOPT=MGGSTR
            ENDIF
 210      CONTINUE
        ENDIF
        IF (IOPT(IC1).NE.0) THEN
C...Save pair with largest RLOPT so far
          IF (RLOPT.GE.RLMAX) THEN
            ICRMAX=IC1
            RLMAX=RLOPT
          ENDIF
        ENDIF
 230  CONTINUE
C...Save and iterate
      IF (ICRMAX.GT.0) THEN
        LCT=LCT+1
        ILMAX=ICR(ICRMAX)
        JLMAX=IOPT(ICRMAX)
        ICMAX=MSCR(ICRMAX)
        JCMAX=3-ICMAX
        MCN(ILMAX,ICMAX)=LCT
        MCN(JLMAX,JCMAX)=LCT        
        IF (NLOOP.LE.2*(N-IP)) THEN
          GOTO 160
        ELSE
          CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
          CALL PYSTOP(11)
        ENDIF
      ELSE
C...Save and exit. First check for leftover gluon(s)
        DO 260 I=MAX(1,IP),N
C...Check colour charge
          MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
          IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
          IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
C...Decide where to put left-over gluon (minimal insertion)
            ILMAX=0
            RLMAX=1D19
            DO 250 KCT=NCT+1,LCT
              DO 240 IT=MAX(1,IP),N
                IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
                IF (MCN(IT,1).EQ.KCT) IC=IT
                IF (MCN(IT,2).EQ.KCT) IA=IT
 240          CONTINUE
              RL=FOUR(IC,I)*FOUR(IA,I)
              IF (RL.LT.RLMAX) THEN
                RLMAX=RL
                ICMAX=IC
                IAMAX=IA
              ENDIF
 250        CONTINUE
            LCT=LCT+1
            MCN(I,1)=MCN(ICMAX,1)
            MCN(I,2)=LCT
            MCN(ICMAX,1)=LCT
          ENDIF
 260    CONTINUE
C...Here we need to loop over entire event.
        DO 270 IZ=MAX(1,IP),N
C...Do not erase parton shower colour history
          IF (K(IZ,1).NE.3) GOTO 270
C...Check colour charge
          MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
          IF (MCI.EQ.0) GOTO 270
          IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
          IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
 270    CONTINUE
      ENDIF
      
 9999 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)=ISIGN(9900000,KFH)+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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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 110 JT=1,MSTP(126)+20
        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
      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...Store incoming partons in hadronic CM-frame
      DO 140 JT=1,2
        I=MINT(84)+JT
        K(I,1)=14
        K(I,2)=MINT(14+JT)
        K(I,3)=MINT(83)+2+JT
  140 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 150 J=1,5
          P(I1,J)=P(I2,J)
  150   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 160 J=1,5
          P(I1,J)=P(I2,J)
  160   CONTINUE
  170 CONTINUE
 
C...Define initial partons.
      NTRY=0
  180 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.
  190 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 190
      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 190
        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 190
      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 180
      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
  200   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 200
          GOTO 180
        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 180
      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(95).EQ.1.AND.I.GE.381.AND.I.LE.386) 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(7)=VINT(97)
      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(29)=VINT(39)
        PARI(30)=VINT(40)
        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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
C...Local arrays and saved variables.
      COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
     &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
C...UED: equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
      PARAMETER(KKFLMI=451,KKFLMA=475)
      DIMENSION CHIDEL(3), IUEDPR(25)
      DIMENSION IUEDEQ(KKFLMA),MUED(2)
      COMMON/SW1/SW21,CW21
      DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
     & 6100001,6100002,6100003,6100004,6100005,6100006, 
     & 5100001,5100002,5100003,5100004,5100005,5100006, 
     & 6100011,6100013,6100015,                         
     & 5100012,5100011,5100014,5100013,5100016,5100015, 
     & 5100021,5100022,5100023,5100024/                 
C...Save local variables
      SAVE MOFSV,WIDWSV,WID2SV
C...Initial values
      DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
      DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
      DATA IUEDPR/25*0/
C...UED: inline functions used in kk width calculus
      FKAC1(X,Y)=1.-X**2/Y**2
      FKAC2(X,Y)=2.+X**2/Y**2
 
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,MDCY(KC,3)
        WDTP(I)=0D0
        DO 100 J=0,5
          WDTE(I,J)=0D0
  100   CONTINUE
  110 CONTINUE
 
C...Allow for fudge factor to rescale resonance width.
      FUDGE=1D0
      IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
     &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
        IF(MSTP(110).EQ.KFLA) THEN
          FUDGE=PARP(110)
        ELSEIF(MSTP(110).EQ.-1) THEN
          IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
        ELSEIF(MSTP(110).EQ.-2) THEN
          FUDGE=PARP(110)
        ENDIF
      ENDIF
 
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(I)=FUDGE*WDTP(I)
          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 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...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.
            RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
            WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
     &      4D0*SQRT(RM2R*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
              DO 130 IK=1,4
                ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
  130         CONTINUE
              AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
              AR=-ET*ZMIXC(IZ,1)*TANW
              BL=T3L*(ZMIXC(IZ,2)-ZMIXC(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*
     &        ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
     &        SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(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
              RL=SFMIX(6,1)
              RR=-SFMIX(6,2)
              PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
     &        (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
              WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
     &        (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/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(I)=FUDGE*WDTP(I)
          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.7) THEN
C...b' 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...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(I)=FUDGE*WDTP(I)
          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.8) THEN
C...t' quark.
        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.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(I)=FUDGE*WDTP(I)
          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.17) THEN
C...tau' lepton.
        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.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(I)=FUDGE*WDTP(I)
          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.18) THEN
C...nu'_tau neutrino.
        FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
        DO 180 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 180
          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 180
          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(I)=FUDGE*WDTP(I)
          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.21) THEN
C...QCD:
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...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(I)=FUDGE*WDTP(I)
          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.22) THEN
C...QED photon.
C***Note that widths are not given in dimensional quantities here.
        DO 200 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 200
          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 200
          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(I)=FUDGE*WDTP(I)
          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
  200   CONTINUE
 
      ELSEIF(KFLA.EQ.23) THEN
C...Z0:
        ICASE=1
        XWC=1D0/(16D0*XW*XW1)
        FAC=(AEM*XWC/3D0)*SHR
  210   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 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.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(I)=FUDGE*WDTP(I)
          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
  220   CONTINUE
        IF(MINT(61).GE.1) ICASE=3-ICASE
        IF(ICASE.EQ.2) GOTO 210
 
      ELSEIF(KFLA.EQ.24) THEN
C...W+/-:
        FAC=(AEM/(24D0*XW))*SHR
        DO 230 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 230
          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 230
          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(I)=FUDGE*WDTP(I)
          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
  230   CONTINUE
 
      ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
C...h0 (or H0, or A0):
        SHFS=SH
        FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
        DO 270 I=1,MDCY(KFHIGG,3)
          IDC=I+MDCY(KFHIGG,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 270
          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 270
          WID2=1D0
 
          IF(I.LE.8) THEN
C...h0 -> q + qbar
            WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
     &      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
              IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
                WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
                IF(IHIGG.NE.3) THEN
                  WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
     &            PARU(151+10*IHIGG))**2
                ENDIF
              ENDIF
            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))*(SH/SHFS)
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 240 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
  240       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 250 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
  250       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 260 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
  260       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(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
            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.IHIGG.GE.2) THEN
C...H0 -> Z0 + h0, A0-> Z0 + h0
            WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
     &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            IF(IHIGG.EQ.2) THEN
             WDTP(I)=WDTP(I)*PARU(179)**2
            ELSEIF(IHIGG.EQ.3) THEN
             WDTP(I)=WDTP(I)*PARU(186)**2
            ENDIF
            WID2=WIDS(23,2)*WIDS(25,2)
 
          ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
C...H0 -> h0 + h0, A0-> h0 + h0
            WDTP(I)=FAC*0.25D0*
     &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
            IF(IHIGG.EQ.2) THEN
             WDTP(I)=WDTP(I)*PARU(176)**2
            ELSEIF(IHIGG.EQ.3) THEN
             WDTP(I)=WDTP(I)*PARU(169)**2
            ENDIF
            WID2=WIDS(25,1)
          ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
            WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
     &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
     &      *PARU(195+IHIGG)**2
            IF(I.EQ.20) THEN
              WID2=WIDS(24,2)*WIDS(37,3)
            ELSEIF(I.EQ.21) THEN
              WID2=WIDS(24,3)*WIDS(37,2)
            ENDIF
 
          ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
C...H0 -> Z0 + A0.
            WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
     &      (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(36,2)*WIDS(23,2)
 
          ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
C...H0 -> h0 + A0.
            WDTP(I)=FAC*0.5D0*PARU(180)**2*
     &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
            WID2=WIDS(25,2)*WIDS(36,2)
 
          ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
C...H0 -> A0 + A0
            WDTP(I)=FAC*0.25D0*PARU(177)**2*
     &      PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
            WID2=WIDS(36,1)
 
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(I)=FUDGE*WDTP(I)
          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
  270   CONTINUE
 
      ELSEIF(KFLA.EQ.32) THEN
C...Z'0:
        ICASE=1
        XWC=1D0/(16D0*XW*XW1)
        FAC=(AEM*XWC/3D0)*SHR
        VINT(117)=0D0
  280   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 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.OR.MDME(IDC,1).LT.0) GOTO 290
          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(I)=FUDGE*WDTP(I)
            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
  290   CONTINUE
        IF(MINT(61).GE.1) ICASE=3-ICASE
        IF(ICASE.EQ.2) GOTO 280
 
      ELSEIF(KFLA.EQ.34) THEN
C...W'+/-:
        FAC=(AEM/(24D0*XW))*SHR
        DO 300 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 300
          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 300
          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(I)=FUDGE*WDTP(I)
          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.37) THEN
C...H+/-:
C        IF(MSTP(49).EQ.0) THEN
        SHFS=SH
C        ELSE
C          SHFS=PMAS(37,1)**2
C        ENDIF
        FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
        DO 310 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 310
          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 310
          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))*(SH/SHFS)
            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))*(SH/SHFS)
            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(I)=FUDGE*WDTP(I)
          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.41) THEN
C...R:
        FAC=(AEM/(12D0*XW))*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
          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(I)=FUDGE*WDTP(I)
          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.42) THEN
C...LQ (leptoquark).
        FAC=(AEM/4D0)*PARU(151)*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
          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(I)=FUDGE*WDTP(I)
          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
 
C...UED: kk state width decays : flav: 451 476
      ELSEIF(IUED(1).EQ.1.AND.
     &       PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
     &       PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
         KCLA=PYCOMP(KFLA)
C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
         RMFLAS=PMAS(KCLA,1)
         FACSH=SH/PMAS(KCLA,1)**2
         ALPHEM=PYALEM(RMFLAS**2)
         ALPHS=PYALPS(RMFLAS**2)

C...uedcor parameters (alpha_s is calculated at mkk scale)
C...alpha_em is calculated at z pole !
         ALPHEM=PARU(101)
         FACSH=1.
         
         DO 1070 I=1,MDCY(KCLA,3)
          IDC=I+MDCY(KCLA,2)-1

          IF(MDME(IDC,1).LT.0) GOTO 1070
          KFC1=PYCOMP(ABS(KFDP(IDC,1)))
          KFC2=PYCOMP(ABS(KFDP(IDC,2)))
          RM1=PMAS(KFC1,1)**2/SH
          RM2=PMAS(KFC2,1)**2/SH
          IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
     &    GOTO 1070
          WID2=1D0

C...N.B. RINV=RUED(1)
          RMKK=RUED(1)
          RMWKK=PMAS(475,1)
          RMZKK=PMAS(474,1)
          SW2=PARU(102)
          CW2=1.-SW2 
          KKCLA=KCLA-KKFLMI+1
          IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
          IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
          IF(KKCLA.LE.6) THEN
C...q*_S -> q + gamma* (in first time sw21=0)
             FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
C...Eventually change the following by enabling a choice of open or closed.
C...Only the gamma_kk channel is open.
             IF(MOD(I,2).EQ.0)
     +            WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
             WDTP(I)=FACSH*WDTP(I)
             WID2=WIDS(473,2)
           ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
C...q*_D -> q + Z*/W*
              FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
              GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
              IF(I.EQ.1)THEN
C...q*_D -> q + Z*
                 WDTP(I)=0.5*GAMMAW
                 WID2=WIDS(474,2)                 
              ELSEIF(I.EQ.2)THEN
C...q*_D -> q + W*
                 WDTP(I)=GAMMAW
                 WID2=WIDS(475,2)                 
              ENDIF
              WDTP(I)=FACSH*WDTP(I)
C...q*_D -> q + gamma* is closed
           ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
              FAC=ALPHEM/4.*RMFLAS/CW2/8.
              RMGAKK=PMAS(473,1)
              WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
     +                FKAC1(RMGAKK,RMFLAS)**2
              WDTP(I)=FACSH*WDTP(I)
              WID2=WIDS(473,2)
           ELSEIF(KKCLA.EQ.22)THEN
              RMQST=PMAS(KKPART,1)
              WID2=WIDS(KKPART,2)
C...g* -> q*_S/q*_D + q
              FAC=10.*ALPHS/12.*RMFLAS
              WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
              WDTP(I)=FACSH*WDTP(I)
           ELSEIF(KKCLA.EQ.23)THEN
C...gamma* decays to graviton + gamma : initial value is used
             ICHI=IUED(4)/2
             WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
     &            *CHIDEL(ICHI)
           ELSEIF(KKCLA.EQ.24)THEN 
C...Z* -> l*_S + l is closed
C...  Z* -> l*_D + l
             IF(I.LE.3)GOTO 1070
c...  After closing the channels for a Z* decaying into positively charged 
C...  KK lepton singlets, close the channels for a Z* decaying into negatively 
C...  charged KK lepton singlets + positively charged SM particles
             IF(I.GE.10.AND.I.LE.12)GOTO 1070
             FAC=3./2.*ALPHEM/24./SW2*RMZKK
             RMLST=PMAS(KKPART,1)
             WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
             WDTP(I)=FACSH*WDTP(I)
             WID2=WIDS(KKPART,2)                 
           ELSEIF(KKCLA.EQ.25)THEN 
C...W* -> l*_D lbar
             FAC=3.*ALPHEM/12./SW2*RMWKK
             RMLST=PMAS(KKPART,1)
             WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
             WDTP(I)=FACSH*WDTP(I)
             WID2=WIDS(KKPART,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
 1070   CONTINUE
        IUEDPR(KKCLA)=1

      ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
C...Techni-pi0 and techni-pi0':
        FAC=(1D0/(32D0*PARU(1)*RTCM(1)**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_tc -> g + g
          IF(I.EQ.8) THEN
            FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
     &      /(8D0*PARU(1))*SH*SHR
            IF(KFLA.EQ.KTECHN+111) THEN
              FACP=FACP*RTCM(9)
            ELSE
              FACP=FACP*RTCM(10)
            ENDIF
            WDTP(I)=FACP
          ELSE
C...pi_tc -> 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*RTCM(1+IKA)**2
               HM1=PYMRUN(KFDP(IDC,1),SH)
               HM2=PYMRUN(KFDP(IDC,2),SH)
            ELSEIF(IKA.EQ.15) THEN
               FCOF=FCOF*RTCM(8)**2
            ENDIF
            WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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.KTECHN+211) THEN
C...pi+_tc
        FAC=(1D0/(32D0*PARU(1)*RTCM(1)**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.5) 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_tc -> f + f'.
          FCOF=1D0
          IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
C...pi_tc+ -> W b b~
          IF(I.EQ.5.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*RTCM(7)**2
            KFC3=PYCOMP(KFDP(IDC,3))
            CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
            CHECK = SQRT(RM1)
            T0 = (1D0-CHECK**2)*
     &      (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
     &      (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
            T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
     &      -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
            T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*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.5) THEN
              IF(I.LE.2) THEN
                FCOF=FCOF*RTCM(5)**2
              ELSEIF(I.LE.4) THEN
                FCOF=FCOF*RTCM(6)**2
              ELSEIF(I.EQ.5) THEN
                FCOF=FCOF*RTCM(7)**2
              ENDIF
              HM1=PYMRUN(KFDP(IDC,1),SH)
              HM2=PYMRUN(KFDP(IDC,2),SH)
            ELSEIF(I.EQ.8) THEN
              FCOF=FCOF*RTCM(8)**2
            ENDIF
            WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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.KTECHN+331) THEN
C...Techni-eta.
        FAC=(SH/PARP(46)**2)*SHR
        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.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(I)=FUDGE*WDTP(I)
          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.KTECHN+113) THEN
C...Techni-rho0:
        ALPRHT=2.16D0*(3D0/ITCM(1))
        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 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_tc0 -> W+ + W-.
C... Multiplied by  2 for W^+_T W^-_L + W^+_L W^-_T  
            WDTP(I)=FAC*RTCM(3)**4*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
     &      2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
     &      ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
     &      RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
            WID2=WIDS(24,1)
          ELSEIF(I.EQ.2) THEN
C...rho_tc0 -> W+ + pi_tc-.
C... Multiplied by  2 for pi_T^+ W^-_T + pi_T^- W^+_T  
            WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**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*RM1)*
     &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
            WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
          ELSEIF(I.EQ.3) THEN
C...rho_tc0 -> pi_tc+ + W-.
            WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**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*RM2)*
     &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
            WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
          ELSEIF(I.EQ.4) THEN
C...rho_tc0 -> pi_tc+ + pi_tc-.
            WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(PYCOMP(KTECHN+211),1)
          ELSEIF(I.EQ.5) THEN
C...rho_tc0 -> gamma + pi_tc0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
     &      SHR**3
            WID2=WIDS(PYCOMP(KTECHN+111),2)
          ELSEIF(I.EQ.6) THEN
C...rho_tc0 -> gamma + pi_tc0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
            WID2=WIDS(PYCOMP(KTECHN+221),2)
          ELSEIF(I.EQ.7) THEN
C...rho_tc0 -> Z0 + pi_tc0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
          ELSEIF(I.EQ.8) THEN
C...rho_tc0 -> Z0 + pi_tc0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
          ELSEIF(I.EQ.9) THEN
C...rho_tc0 -> gamma + Z0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
            WID2=WIDS(23,2)
          ELSEIF(I.EQ.10) THEN
C...rho_tc0 -> Z0 + Z0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
     &      SHR**3
            WID2=WIDS(23,1)
          ELSE
C...rho_tc0 -> f + fbar.
            WID2=1D0
            IF(I.LE.18) THEN
              IA=I-10
              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(I)=FUDGE*WDTP(I)
          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.KTECHN+213) THEN
C...Techni-rho+/-:
        ALPRHT=2.16D0*(3D0/ITCM(1))
        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 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
          PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
c            WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
c     &      /3D0*SHR**3
          IF(I.EQ.1) THEN
C...rho_tc+ -> W+ + Z0.
C......Goldstone
            WDTP(I)=FAC*RTCM(3)**4*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
            AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
C......W_L Z_T
            WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
     &      /3D0*SHR**3
            VA2=0D0
            AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
C......W_T Z_L
            WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
     &      /3D0*SHR**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_tc+ -> W+ + pi_tc0.
            WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**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-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
            ELSE
              WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
            ENDIF
          ELSEIF(I.EQ.3) THEN
C...rho_tc+ -> pi_tc+ + Z0.
            WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**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-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
     &      AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
     &      SHR**3*XW/XW1
            IF(KFLR.GT.0) THEN
              WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
            ELSE
              WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
            ENDIF
          ELSEIF(I.EQ.4) THEN
C...rho_tc+ -> pi_tc+ + pi_tc0.
            WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
            ELSE
              WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
            ENDIF
          ELSEIF(I.EQ.5) THEN
C...rho_tc+ -> pi_tc+ + gamma
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
     &      SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(PYCOMP(KTECHN+211),2)
            ELSE
              WID2=WIDS(PYCOMP(KTECHN+211),3)
            ENDIF
          ELSEIF(I.EQ.6) THEN
C...rho_tc+ -> W+ + pi_tc0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
            ELSE
              WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
            ENDIF
          ELSEIF(I.EQ.7) THEN
C...rho_tc+ -> W+ + gamma
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
            IF(KFLR.GT.0) THEN
              WID2=WIDS(24,2)
            ELSE
              WID2=WIDS(24,3)
            ENDIF
          ELSE
C...rho_tc+ -> f + fbar'.
            IA=I-7
            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(I)=FUDGE*WDTP(I)
          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.KTECHN+223) THEN
C...Techni-omega:
        ALPRHT=2.16D0*(3D0/ITCM(1))
        FAC=(ALPRHT/12D0)*SHR
        FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-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 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...omega_tc0 -> gamma + pi_tc0.
            WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
            WID2=WIDS(PYCOMP(KTECHN+111),2)
          ELSEIF(I.EQ.2) THEN
C...omega_tc0 -> Z0 + pi_tc0
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
          ELSEIF(I.EQ.3) THEN
C...omega_tc0 -> gamma + pi_tc0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
     &      SHR**3
            WID2=WIDS(PYCOMP(KTECHN+221),2)
          ELSEIF(I.EQ.4) THEN
C...omega_tc0 -> Z0 + pi_tc0'
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
     &      XW/XW1*SHR**3
            WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
          ELSEIF(I.EQ.5) THEN
C...omega_tc0 -> W+ + pi_tc-
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
     &      FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
          ELSEIF(I.EQ.6) THEN
C...omega_tc0 -> pi_tc+ + W-
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
     &      FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
          ELSEIF(I.EQ.7) THEN
C...omega_tc0 -> W+ + W-.
C... Multiplied by  2 for W^+_T W^-_L + W^+_L W^-_T  
            WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
     &      2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
            WID2=WIDS(24,1)
          ELSEIF(I.EQ.8) THEN
C...omega_tc0 -> pi_tc+ + pi_tc-.
            WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
            WID2=WIDS(PYCOMP(KTECHN+211),1)
C...omega_tc0 -> gamma + Z0
          ELSEIF(I.EQ.9) THEN
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
            WID2=WIDS(23,2)
C...omega_tc0 -> Z0 + Z0
          ELSEIF(I.EQ.10) THEN
            WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
     &      RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
     &      /24D0/RTCM(12)**2*SHR**3
            WID2=WIDS(23,1)
          ELSE
C...omega_tc0 -> f + fbar.
            WID2=1D0
            IF(I.LE.18) THEN
              IA=I-10
              FCOF=3D0*RADC
              IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
            ELSE
              IA=I-8
              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(I)=FUDGE*WDTP(I)
          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
 
C.....V8 -> quark anti-quark
      ELSEIF(KFLA.EQ.KTECHN+100021) THEN
        FAC=AS/6D0*SHR
        TANT3=RTCM(21)
        IF(ITCM(2).EQ.0) THEN
          IMDL=1
        ELSEIF(ITCM(2).EQ.1) THEN
          IMDL=2
        ENDIF
        DO 400 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 400
          PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
          RM1=PM1**2/SH
          IF(RM1.GT.0.25D0) GOTO 400
          WID2=1D0
          IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
            FMIX=1D0/TANT3**2
          ELSE
            FMIX=TANT3**2
          ENDIF
          WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
          IF(I.EQ.6) WID2=WIDS(6,1)
          WDTP(I)=FUDGE*WDTP(I)
          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.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
        FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
        CLEBF=0D0
        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
C...pi_tc -> g + g
          IF(I.EQ.7) THEN
            IF(KFLA.EQ.KTECHN+100111) THEN
              CLEBG=4D0/3D0
            ELSE
              CLEBG=5D0/3D0
            ENDIF
            FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
     &      /(2D0*PARU(1))*SH*SHR*CLEBG
            WDTP(I)=FACP
          ELSE
C...pi_tc -> f + fbar.
            IF(I.EQ.6) WID2=WIDS(6,1)
            FCOF=1D0
            IKA=IABS(KFDP(IDC,1))
            IF(IKA.LT.10) FCOF=3D0*RADC
            HM1=PYMRUN(KFDP(IDC,1),SH)
            WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
     &      SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
        FAC=AS/6D0*SHR
        ALPRHT=2.16D0*(3D0/ITCM(1))
        TANT3=RTCM(21)
        SIN2T=2D0*TANT3/(TANT3**2+1D0)
        SINT3=TANT3/SQRT(TANT3**2+1D0)
        CSXPP=RTCM(22)
        RM82=RTCM(27)**2
        X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
     &  RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
        X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
     &  RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
        X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
     &  SINT3**2)*2D0
        X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
     &  SINT3**2)*2D0
        CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
 
        IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
        GMV8=SHR*WDTPP(0)
        RMV8=PMAS(PYCOMP(KTECHN+100021),1)
        FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
        FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
        IF(ITCM(2).EQ.0) THEN
          IMDL=1
        ELSE
          IMDL=2
        ENDIF
        DO 420 I=1,MDCY(KC,3)
          IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
     &    KFLA.EQ.KTECHN+300113)) GOTO 420
          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.LE.6) THEN
            IF(I.EQ.6) WID2=WIDS(6,1)
            XIG=1D0
            IF(KFLA.EQ.KTECHN+200113) THEN
              XIG=0D0
              XIJ=X12
            ELSEIF(KFLA.EQ.KTECHN+300113) THEN
              XIG=0D0
              XIJ=X21
            ELSEIF(KFLA.EQ.KTECHN+100113) THEN
              XIJ=X11
            ELSE
              XIJ=X22
            ENDIF
            IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
              FMIX=1D0/TANT3/SIN2T
            ELSE
              FMIX=-TANT3/SIN2T
            ENDIF
            XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
            WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
          ELSEIF(I.EQ.7) THEN
            WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
          ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
            PSH=SHR*(1D0-RM1)/2D0
            WDTP(I)=AS/9D0*PSH**3/RM82
            IF(I.EQ.8) THEN
              WDTP(I)=2D0*WDTP(I)*CSXPP**2
              WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
            ELSE
              WDTP(I)=5D0*WDTP(I)
              WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
            ENDIF
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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
 
      ELSEIF(KFLA.EQ.KEXCIT+1) THEN
C...d* excited quark.
        FAC=(SH/RTCM(41)**2)*SHR
        DO 430 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 430
          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 430
          WID2=1D0
          IF(I.EQ.1) THEN
C...d* -> g + d.
            WDTP(I)=FAC*AS*RTCM(45)**2/3D0
            WID2=1D0
          ELSEIF(I.EQ.2) THEN
C...d* -> gamma + d.
            QF=-RTCM(43)/2D0+RTCM(44)/6D0
            WDTP(I)=FAC*AEM*QF**2/4D0
            WID2=1D0
          ELSEIF(I.EQ.3) THEN
C...d* -> Z0 + d.
            QF=-RTCM(43)*XW1/2D0-RTCM(44)*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*RTCM(43)**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(I)=FUDGE*WDTP(I)
          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
  430   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+2) THEN
C...u* excited quark.
        FAC=(SH/RTCM(41)**2)*SHR
        DO 440 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 440
          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 440
          WID2=1D0
          IF(I.EQ.1) THEN
C...u* -> g + u.
            WDTP(I)=FAC*AS*RTCM(45)**2/3D0
            WID2=1D0
          ELSEIF(I.EQ.2) THEN
C...u* -> gamma + u.
            QF=RTCM(43)/2D0+RTCM(44)/6D0
            WDTP(I)=FAC*AEM*QF**2/4D0
            WID2=1D0
          ELSEIF(I.EQ.3) THEN
C...u* -> Z0 + u.
            QF=RTCM(43)*XW1/2D0-RTCM(44)*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*RTCM(43)**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(I)=FUDGE*WDTP(I)
          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
  440   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+11) THEN
C...e* excited lepton.
        FAC=(SH/RTCM(41)**2)*SHR
        DO 450 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 450
          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 450
          WID2=1D0
          IF(I.EQ.1) THEN
C...e* -> gamma + e.
            QF=-RTCM(43)/2D0-RTCM(44)/2D0
            WDTP(I)=FAC*AEM*QF**2/4D0
            WID2=1D0
          ELSEIF(I.EQ.2) THEN
C...e* -> Z0 + e.
            QF=-RTCM(43)*XW1/2D0+RTCM(44)*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*RTCM(43)**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(I)=FUDGE*WDTP(I)
          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
  450   CONTINUE
 
      ELSEIF(KFLA.EQ.KEXCIT+12) THEN
C...nu*_e excited neutrino.
        FAC=(SH/RTCM(41)**2)*SHR
        DO 460 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 460
          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 460
          WID2=1D0
          IF(I.EQ.1) THEN
C...nu*_e -> Z0 + nu*_e.
            QF=RTCM(43)*XW1/2D0+RTCM(44)*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*RTCM(43)**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(I)=FUDGE*WDTP(I)
          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
  460   CONTINUE
 
      ELSEIF(KFLA.EQ.KDIMEN+39) THEN
C...G* (graviton resonance):
        FAC=(PARP(50)**2/PARU(1))*SHR
        DO 470 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 470
          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 470
          WID2=1D0
          IF(I.LE.8) THEN
C...G* -> q + qbar
            FCOF=3D0*RADC
            IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
     &      PYHFTH(SH,SH*RM1,1D0)
            WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
     &      (1D0+8D0*RM1/3D0)/320D0
            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...G* -> l+ + l-, nu + nubar
            FCOF=1D0
            WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
     &      (1D0+8D0*RM1/3D0)/320D0
            IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
          ELSEIF(I.EQ.17) THEN
C...G* -> g + g.
            WDTP(I)=FAC/20D0
          ELSEIF(I.EQ.18) THEN
C...G* -> gamma + gamma.
            WDTP(I)=FAC/160D0
          ELSEIF(I.EQ.19) THEN
C...G* -> Z0 + Z0.
            WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
     &      14D0*RM1/3D0+4D0*RM1**2)/160D0
            WID2=WIDS(23,1)
          ELSEIF(I.EQ.20) THEN
C...G* -> W+ + W-.
            WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
     &      14D0*RM1/3D0+4D0*RM1**2)/80D0
            WID2=WIDS(24,1)
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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
  470   CONTINUE
 
      ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
        PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
        FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
        DO 480 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 480
          PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
          PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
          PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
          IF(PM1+PM2+PM3.GE.SHR) GOTO 480
          WID2=1D0
          IF(I.LE.9) THEN
C...nu_lR -> l- qbar q'
            FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
            IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
          ELSEIF(I.LE.18) THEN
C...nu_lR -> l+ q qbar'
            FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
            IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
          ELSE
C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
            FCOF=1D0
            WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
          ENDIF
          X=(PM1+PM2+PM3)/SHR
          FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
          Y=(SHR/PMWR)**2
          FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
          WDTP(I)=FAC*FCOF*FX*FY
          WDTP(I)=FUDGE*WDTP(I)
          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
  480   CONTINUE
 
      ELSEIF(KFLA.EQ.9900023) THEN
C...Z_R0:
        FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
        DO 490 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 490
          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 490
          WID2=1D0
          SYMMET=1D0
          IF(I.LE.6) THEN
C...Z_R0 -> q + qbar
            EF=KCHG(I,1)/3D0
            AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
            VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
            FCOF=3D0*RADC
            IF(I.EQ.6) WID2=WIDS(6,1)
          ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
C...Z_R0 -> l+ + l-
            AF=-(1D0-2D0*XW)
            VF=-1D0+4D0*XW
            FCOF=1D0
          ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
            AF=-2D0*XW
            VF=0D0
            FCOF=1D0
            SYMMET=0.5D0
          ELSEIF(I.LE.15) THEN
C...Z0 -> nu_R + nu_R, assumed Majorana.
            AF=2D0*XW1
            VF=0D0
            FCOF=1D0
            WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
            SYMMET=0.5D0
          ENDIF
          WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
     &    SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
          WDTP(I)=FUDGE*WDTP(I)
          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
  490   CONTINUE
 
      ELSEIF(KFLA.EQ.9900024) THEN
C...W_R+/-:
        FAC=(AEM/(24D0*XW))*SHR
        DO 500 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 500
          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 500
          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(I)=FUDGE*WDTP(I)
          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
  500  CONTINUE
 
      ELSEIF(KFLA.EQ.9900041) THEN
C...H_L++/--:
        FAC=(1D0/(8D0*PARU(1)))*SHR
        DO 510 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 510
          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 510
          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
            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(I)=FUDGE*WDTP(I)
          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
  510   CONTINUE
 
      ELSEIF(KFLA.EQ.9900042) THEN
C...H_R++/--:
        FAC=(1D0/(8D0*PARU(1)))*SHR
        DO 520 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 520
          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 520
          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(PYCOMP(9900024),4+(1-KFLS)/2)
          ENDIF
          WDTP(I)=FAC*FCOF*
     &    SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          WDTP(I)=FUDGE*WDTP(I)
          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
  520  CONTINUE

      ELSEIF(KFLA.EQ.KTECHN+115) THEN
C...Techni-a2:
C...Need to update to alpha_rho
        ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
        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/(4D0*XW*(1D0-XW))
        BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
        BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
        DO 530 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 530
          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 530
          WID2=1D0
          PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          IF(I.LE.4) THEN
            FACPV=PCM**2
            FACPA=PCM**2+1.5D0*RM1            
            VA2=0D0
            AA2=0D0
C...a2_tc0 -> W+ + W-
            IF(I.EQ.1) THEN
              AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
              WID2=WIDS(24,1)
C...a2_tc0 -> W+ + pi_tc- + c.c.
            ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
              AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
              IF(I.EQ.6) THEN
                WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
              ELSE
                WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
              ENDIF
            ELSEIF(I.EQ.4) THEN
C...a2_tc0 -> Z0 + pi_tc0'
              VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
              WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
            ENDIF
            WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
          ELSEIF(I.GE.5.AND.I.LE.10) THEN
            FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
            FACPA=PCM**2*(1D0+RM1+RM2)
            VA2=0D0
            AA2=0D0
            IF(I.EQ.5) THEN
C...a_T^0 -> gamma rho_T^0
              VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
              WID2=WIDS(PYCOMP(KTECHN+113),2)
            ELSEIF(I.EQ.6) THEN
C...a_T^0 -> gamma omega_T
              VA2=1D0/RTCM(50)**4
              WID2=WIDS(PYCOMP(KTECHN+223),2)
            ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
C...a_T^0 -> W^+- rho_T^-+
              AA2=.25D0/XW/RTCM(51)**4
              IF(I.EQ.7) THEN
                WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
              ELSE
                WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
              ENDIF
            ELSEIF(I.EQ.9) THEN
C...a_T^0 -> Z^0 rho_T^0
              VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
              WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
            ELSEIF(I.EQ.10) THEN
C...a_T^0 -> Z^0 omega_T
              VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
              WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
            ENDIF            
            WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
          ELSE
C...a2_tc0 -> f + fbar.
            WID2=1D0
            IF(I.LE.18) THEN
              IA=I-10
              FCOF=3D0*RADC
              IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
            ELSE
              IA=I-8
              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)*
     &      ((VALI*BWZR)**2+(VALI*BWZI)**2+
     &      (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
     &      (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
          ENDIF
          WDTP(I)=FUDGE*WDTP(I)
          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
  530   CONTINUE
 
      ELSEIF(KFLA.EQ.KTECHN+215) THEN
C...Techni-a2+/-:
        ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
        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 540 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 540
          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 540
          WID2=1D0
          PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
          IF(KFLR.GT.0) THEN
            ICHANN=2
          ELSE
            ICHANN=3
          ENDIF
          IF(I.LE.7) THEN
            AA2=0
            VA2=0
C...a2_tc+ -> gamma + W+.
            IF(I.EQ.1) THEN
              AA2=RTCM(3)**2/RTCM(49)**2
              WID2=WIDS(24,ICHANN)
C...a2_tc+ -> gamma + pi_tc+.
            ELSEIF(I.EQ.2) THEN
              AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
              WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
C...a2_tc+ -> W+ + Z
            ELSEIF(I.EQ.3) THEN
              AA2=RTCM(3)**2*(1D0/4D0/XW1 +
     &                       (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
              WID2=WIDS(24,ICHANN)*WIDS(23,2)
C...a2_tc+ -> W+ + pi_tc0.
            ELSEIF(I.EQ.4) THEN
              AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
              WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
C...a2_tc+ -> W+ + pi_tc'0.
            ELSEIF(I.EQ.5) THEN
              VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
              WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
C...a2_tc+ -> Z0 + pi_tc+.
            ELSEIF(I.EQ.6) THEN
              AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
     &         RTCM(49)**2
              WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
            ENDIF
            WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
     &      /3D0*SHR**3
          ELSEIF(I.LE.10) THEN
            FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
            FACPA=PCM**2*(1D0+RM1+RM2)
            VA2=0D0
            AA2=0D0
C...a2_tc+ -> gamma + rho_tc+
            IF(I.EQ.7) THEN
              VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
              WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
C...a2_tc+ -> W+ + rho_T^0
            ELSEIF(I.EQ.8) THEN
              AA2=1D0/(4D0*XW)/RTCM(51)**4
              WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
C...a2_tc+ -> W+ + omega_T
            ELSEIF(I.EQ.9) THEN
              VA2=.25D0/XW/RTCM(50)**4
              WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
C...a2_tc+ -> Z^0  + rho_T^+
            ELSEIF(I.EQ.10) THEN
              VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
              AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
              WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
            ENDIF            
            WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
          ELSE
C...a2_tc+ -> f + fbar'.
            IA=I-10
            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(I)=FUDGE*WDTP(I)
          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
  540   CONTINUE
 
      ENDIF
      MINT(61)=0
      MINT(62)=0
      MINT(63)=0
      RETURN
      END
 
C***********************************************************************
 
C...PYOFSH
C...Calculates partial width and differential cross-section maxima
C...of channels/processes not allowed on mass-shell, and selects
C...masses in such channels/processes.
 
      SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      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(8000,2),BRAT(8000),KFDP(8000,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:400),
     &WDTE(0:400,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.AND.MSTP(171).EQ.0) 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)
        IF(MINT(51).NE.0) RETURN
 
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(8000,2),BRAT(8000),KFDP(8000,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

        IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
        IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)

      ELSEIF(ILIM.EQ.4) THEN
C...Calculate limits on tau'
C...0) due to kinematics
        TAPMN0=TAU
        IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
          PQRAT=(VINT(201)+VINT(206))/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)
        ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
          TAURE=VINT(77)
          GAMRE=VINT(78)
        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.OR.MVAR.EQ.8) THEN
          RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
          TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
        ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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/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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      COMMON/PYTCCO/COEFX(194:380,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
     &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
     &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
C...Local arrays and complex variables
      DIMENSION XPQ(-25:25)
 
C...Map of processes onto which routine to call
C...in order to evaluate cross section:
C...0 = not implemented;
C...1 = standard QCD (including photons);
C...2 = heavy flavours;
C...3 = W/Z;
C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
C...5 = SUSY;
C...6 = Technicolor;
C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
C...8 = Universal Extra Dimensions
      DIMENSION MAPPR(500)
      DATA (MAPPR(I),I=1,180)/
     &    3,  3,  4,  0,  4,  0,  0,  4,  0,  1,
     1    1,  1,  1,  1,  3,  3,  0,  1,  3,  3,
     2    0,  3,  3,  4,  3,  4,  0,  1,  1,  3,
     3    3,  4,  1,  1,  3,  3,  0,  0,  0,  0,
     4    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     5    0,  0,  1,  1,  0,  0,  0,  1,  0,  0,
     6    0,  0,  0,  0,  0,  0,  0,  1,  3,  3,
     7    4,  4,  4,  0,  0,  4,  4,  0,  0,  1,
     8    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     9    1,  1,  1,  1,  1,  1,  0,  0,  1,  0,
     &    0,  4,  4,  2,  2,  2,  2,  2,  0,  4,
     1    4,  4,  4,  1,  1,  0,  0,  0,  0,  0,
     2    4,  4,  4,  4,  0,  0,  0,  0,  0,  0,
     3    1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4    7,  7,  4,  7,  7,  7,  7,  7,  6,  0,
     5    4,  4,  4,  0,  0,  4,  4,  4,  0,  0,
     6    4,  7,  7,  7,  6,  6,  7,  7,  7,  0,
     7    4,  4,  4,  4,  0,  4,  4,  4,  4,  0/
      DATA (MAPPR(I),I=181,500)/
     8    4,  4,  4,  4,  4,  4,  4,  4,  4,  4,
     9    6,  6,  6,  6,  6,  0,  0,  0,  0,  0,
     &    100*5,
     &    5,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &    8,  8,  8,  8,  8,  8,  8,  8,  8,  0,
     1    20*0,
     4    7,  7,  7,  7,  7,  7,  7,  7,  7,  7,
     5    7,  7,  7,  7,  0,  0,  0,  0,  0,  0,
     6    6,  6,  6,  6,  6,  6,  6,  6,  0,  6,
     7    6,  6,  6,  6,  6,  6,  6,  6,  6,  6,
     8    6,  6,  6,  6,  6,  6,  6,  6,  0,  0,
     9    7,  7,  7,  7,  7,  0,  0,  0,  0,  0,
     &    4,  4,  18*0,
     2    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
     3    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     4     20*0,
     6    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
     7    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     8     20*0/
 
C...Reset number of channels and cross-section
      NCHN=0
      SIGS=0D0
 
C...Read process to consider.
      ISUB=MINT(1)
      ISUBSV=ISUB
      MAP=MAPPR(ISUB)
 
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 for hard process (e.g. alpha_s).
      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)
C..Begin JA 040914
        ELSEIF(MSTP(32).EQ.11) THEN
          Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
        ELSEIF(MSTP(32).EQ.12) THEN
          Q2=PARP(193)
C..End JA
        ELSEIF(MSTP(32).EQ.13) THEN
          Q2=SQPTH
        ENDIF
        IF(MINT(35).LE.2.AND.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
 
C...Choice of Q2 scale for parton densities.
      Q2SF=Q2
C..Begin JA 040914
      IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
     &     .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
     &     Q2=PARP(194)
C..End JA
      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.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2 
        IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
        IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
     &  ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
          Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
          IF(MSTP(39).EQ.2) Q2SF=
     &         MAX(VINT(201)**2+VINT(202),VINT(206)**2+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(PYCOMP(KFPR(ISUBSV,1)),1)**2
C..Begin JA 040914
          IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
          IF(MSTP(39).EQ.7) Q2SF=
     &         (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
          IF(MSTP(39).EQ.8) Q2SF=PARP(193)
C..End JA
        ENDIF
      ENDIF
      IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
 
      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)
 
C...Identify to which class(es) subprocess belongs
      ISMECR=0
      ISQCD=0
      ISJETS=0
      IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
     &     ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
     &     ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
     &     ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
      IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
     &     ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
      IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
      IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
      IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
      IF (ISTSB.EQ.9) ISQCD=1
      IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
     &     (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
     &     ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
     &     ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
     &     (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
     &     ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
     &     ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
     &     (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
C...WBF is special case of ISJETS
      IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
     &    (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
     &    ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
     &    (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
     &    ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
     &    ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
     &    ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
     &    ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
     &    ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
C...Some processes with photons also belong here.
      IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
     &     (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
     &     ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
     &     ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
     &     (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
     &     (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3

C...Choice of Q2 scale for parton-shower activity.
      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
C...For multiple interactions, start from scale defined above
C...For all other QCD or "+jets"-type events, start shower from pThard.
      IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
      IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
C...Max shower scale = s for ME corrected processes.
C...(pT-ordering: max pT2 is s/4)
        Q2PS=VINT(2)
        IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
      ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
C...(pT-ordering: max pT2 is s/4)
        Q2PS=VINT(2)
        IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
      ENDIF
      IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH

C...Elastic and diffractive events not associated with scales so set 0.
      IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
        Q2SF=0D0
        Q2PS=0D0
      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...Set starting scale for multiple interactions
      IF (ISUBSV.EQ.95) THEN
        XT2GMX=0D0
      ELSEIF(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
C...All accessible phase space allowed.
        XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
      ELSE
C...Scale of hard process sets limit.
C...2 -> 1. Limit is tau = x1*x2.
C...2 -> 2. Limit is XT2 for hard process + FS masses.
C...2 -> n > 2. Limit is tau' = tau of outer process.
        XT2GMX=VINT(25)
        IF(ISTSB.EQ.1) XT2GMX=VINT(21)
        IF(ISTSB.EQ.2)
     &      XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
      ENDIF
      VINT(62)=0.25D0*XT2GMX*VINT(2)
      VINT(61)=SQRT(MAX(0D0,VINT(62)))
 
C...Calculate parton distributions
      IF(ISTSB.LE.0) GOTO 160
      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
            IF(MINT(140+I).EQ.0) THEN
              XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
            ELSE
              XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
            ENDIF
            VINT(40+I)=XSF
            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
C...Safety margin against heavy flavour very close to threshold,
C...e.g. caused by mismatch in c and b masses.
          IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
            XPQ(4)=0D0
            XPQ(-4)=0D0
          ENDIF
          IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
            XPQ(5)=0D0
            XPQ(-5)=0D0
          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
      GMMZ=PMAS(23,1)*PMAS(23,2)
      GMMW=PMAS(24,1)*PMAS(24,2)
 
C...Polarization factors...implemented so far for W+W-(25)
      POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
      POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
      POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
      POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
 
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).GE.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(72).EQ.3) THEN
          TAUR3=VINT(77)
          GAMR3=VINT(78)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
          ATAU50=ATAUD/TAUR3
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
          ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
          ATAU60=ATAUD/GAMR3
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**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
  160 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 170 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)
  170 CONTINUE
 
C...Evaluate cross sections - done in separate routines by kind
C...of physics, to keep PYSIGH of sensible size.
      IF(MAP.EQ.1) THEN
C...Standard QCD (including photons).
        CALL PYSGQC(NCHN,SIGS)
      ELSEIF(MAP.EQ.2) THEN
C...Heavy flavours.
        CALL PYSGHF(NCHN,SIGS)
      ELSEIF(MAP.EQ.3) THEN
C...W/Z.
        CALL PYSGWZ(NCHN,SIGS)
      ELSEIF(MAP.EQ.4) THEN
C...Higgs (2 doublets; including longitudinal W/Z scattering).
        CALL PYSGHG(NCHN,SIGS)
      ELSEIF(MAP.EQ.5) THEN
C...SUSY.
        CALL PYSGSU(NCHN,SIGS)
      ELSEIF(MAP.EQ.6) THEN
C...Technicolor.
        CALL PYSGTC(NCHN,SIGS)
      ELSEIF(MAP.EQ.7) THEN
C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
        CALL PYSGEX(NCHN,SIGS)
      ELSEIF(MAP.EQ.8) THEN
C... Universal Extra Dimensions
         CALL PYXUED(NCHN,SIGS)
      ENDIF
 
C...Multiply with parton distributions
      IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
        DO 180 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)
  180   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGQC
C...Subprocess cross sections for QCD processes,
C...including photons.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGQC(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      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/PYINT7/SIGT(0:6,0:6,0:5)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
     &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
C...Local arrays
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
 
C...Differential cross section expressions.
 
      IF(ISUB.LE.20) THEN
        IF(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 110 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
            IA=IABS(I)
            DO 100 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
              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
C...Extrafactor 2 for only one incoming neutrino spin state.
                IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
                IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
                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
  100       CONTINUE
  110     CONTINUE
 
        ELSEIF(ISUB.EQ.11) THEN
C...f + f' -> f + f' (g exchange)
          FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
          FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
     &    MSTP(34)*2D0/3D0*UH2/(SH*TH))
          FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
     &    MSTP(34)*2D0/3D0*SH2/(TH*UH))
          DO 130 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
            DO 120 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQ1
              IF(I.EQ.-J) SIGH(NCHN)=FACQQB
              IF(I.EQ.J) THEN
                SIGH(NCHN)=0.5D0*SIGH(NCHN)
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=2
                SIGH(NCHN)=0.5D0*FACQQ2
              ENDIF
  120       CONTINUE
  130     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))
          DO 140 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQB
  140     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 150 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
            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
  150     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 160 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
            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
  160     CONTINUE
 
        ELSEIF(ISUB.EQ.18) THEN
C...f + fbar -> gamma + gamma
          FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
          DO 170 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
            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
  170     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.40) THEN
        IF(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 190 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
            DO 180 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
              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
  180       CONTINUE
  190     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 210 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**2
            DO 200 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
  200       CONTINUE
  210     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 230 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**2
            DO 220 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
  220       CONTINUE
  230     CONTINUE
 
        ELSEIF(ISUB.EQ.34) THEN
C...f + gamma -> f + gamma
          FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
          DO 250 I=MMINA,MMAXA
            IF(I.EQ.0) GOTO 250
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**4
            DO 240 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
  240       CONTINUE
  250     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.80) THEN
        IF(ISUB.EQ.53) THEN
C...g + g -> f + fbar (g + g -> q + qbar only)
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
          IDC0=MDCY(21,2)-1
C...Begin by d, u, s flavours.
          FLAVWT=0D0
          IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
          IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
          IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
          FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
     &    UH2/SH2)*FLAVWT*FACA
          FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
     &    TH2/SH2)*FLAVWT*FACA
          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
C...Next c and b flavours: modified that and uhat for fixed
C...cos(theta-hat).
          DO 260 IFL=4,5
          SQMAVG=PMAS(IFL,1)**2
          IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
            BE34=SQRT(1D0-4D0*SQMAVG/SH)
            THQ=-0.5D0*SH*(1D0-BE34*CTH)
            UHQ=-0.5D0*SH*(1D0+BE34*CTH)
            THUHQ=THQ*UHQ-SQMAVG*SH
            IF(MSTP(34).EQ.0) THEN
              FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
              FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
            ELSE
              FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
              FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
            ENDIF
            FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
            FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=1+2*(IFL-3)
            SIGH(NCHN)=FACQQ1
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=2+2*(IFL-3)
            SIGH(NCHN)=FACQQ2
          ENDIF
  260     CONTINUE
  270     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 280 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))
  280     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.58) THEN
C...gamma + gamma -> f + fbar
          CALL PYWIDT(22,SH,WDTP,WDTE)
          WDTESU=0D0
          DO 290 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))
  290     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.68) THEN
C...g + g -> g + g
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
          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)
          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
  300     CONTINUE
 
        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 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
            IF(I.EQ.0) GOTO 320
            EI=KCHG(IABS(I),1)/3D0
            EJ=SIGN(1D0-ABS(EI),EI)
            DO 310 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
  310       CONTINUE
  320     CONTINUE
        ENDIF
 
      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 340 I=-5,5
            IF(I.EQ.0) GOTO 340
            DO 330 J=-5,5
              IF(J.EQ.0) GOTO 330
              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
  330       CONTINUE
  340     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 350 I=-5,5
            IF(I.EQ.0) GOTO 350
            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
  350     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 370 I=-5,5
            IF(I.EQ.0) GOTO 370
            DO 360 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
  360       CONTINUE
  370     CONTINUE
 
C...g + g -> q + qbar (only d, u, s)
          IDC0=MDCY(21,2)-1
          FLAVWT=0D0
          IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
          IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
          IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
          FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
     &    UH2/SH2)*FLAVWT*FACA
          FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
     &    TH2/SH2)*FLAVWT*FACA
          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
 
C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
C...cos(theta-hat)
          DO 380 IFL=4,5
          SQMAVG=PMAS(IFL,1)**2
          IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
            BE34=SQRT(1D0-4D0*SQMAVG/SH)
            THQ=-0.5D0*SH*(1D0-BE34*CTH)
            UHQ=-0.5D0*SH*(1D0+BE34*CTH)
            THUHQ=THQ*UHQ-SQMAVG*SH
            IF(MSTP(34).EQ.0) THEN
              FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
              FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
            ELSE
              FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
              FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
            ENDIF
            FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
            FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=531+2*(IFL-3)
            SIGH(NCHN)=FACQQ1
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=532+2*(IFL-3)
            SIGH(NCHN)=FACQQ2
          ENDIF
  380     CONTINUE
 
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+3+
     &    2D0*UH/TH+UH2/TH2)
          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 390 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
            IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
            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
  390     CONTINUE
        ENDIF
 
      ELSE
        IF(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 400 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
  400     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 410
          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
  410     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 430 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**2
            DO 420 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
  420       CONTINUE
  430     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 450 I=MMINA,MMAXA
            IF(I.EQ.0) GOTO 450
            EI=KCHG(IABS(I),1)/3D0
            FACGQ=FGQ*EI**4
            DO 440 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACGQ
  440       CONTINUE
  450     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 460 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))
  460     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 470 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))
  470     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
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGHF
C...Subprocess cross sections for heavy flavour production,
C...open and closed.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGHF(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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)
      COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
      COMMON/PYINT4/MWID(500),WIDS(500,5)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
     &/PYINT4/,/PYSGCM/
C...Local arrays
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
 
C...Determine where are charmonium/bottomonium wave function parameters.
      IONIUM=140
      IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
 
C...Convert bottomonium process into equivalent charmonium ones.
      IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
 
C...Differential cross section expressions.
 
      IF(ISUB.LE.100) THEN
        IF(ISUB.EQ.81) THEN
C...q + qbar -> Q + Qbar
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
     &    2D0*SQMAVG/SH)
          IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,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 100 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQB
  100     CONTINUE
 
        ELSEIF(ISUB.EQ.82) THEN
C...g + g -> Q + Qbar
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          THUHQ=THQ*UHQ-SQMAVG*SH
          IF(MSTP(34).EQ.0) THEN
            FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
            FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
          ELSE
            FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &      THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
            FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &      UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
          ENDIF
          FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
          FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
          IF(MSTP(35).GE.1) THEN
            FATRE=PYHFTH(SH,SQMAVG,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 110
          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
  110     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 130 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
            DO 120 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
              IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
              IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
              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)
                WID2=1D0
                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
  120       CONTINUE
  130     CONTINUE
 
        ELSEIF(ISUB.EQ.84) THEN
C...g + gamma -> Q + Qbar
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
     &    (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
     &    (THQ*UHQ)
          IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,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)
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
     &    ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
     &    (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
     &    SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
          IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
          IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
     &    FACFF=FACFF*PYHFTH(SH,SQMAVG,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
 
      ELSEIF(ISUB.LE.200) THEN
        IF(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
 
        ELSEIF(ISUB.EQ.106) THEN
C...g + g -> J/Psi + gamma.
          EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/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=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/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=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/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
        ENDIF
 
C...QUARKONIA+++
C...Additional code by Stefan Wolf
      ELSE
 
C...Common code for quarkonium production.
        SHTH=SH+TH
        THUH=TH+UH
        UHSH=UH+SH
        SHTH2=SHTH**2
        THUH2=THUH**2
        UHSH2=UHSH**2
        IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
     &       (ISUB.GE.431.AND.ISUB.LE.433)) THEN
          SQMQQ=SQM3
        ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
     &         (ISUB.GE.434.AND.ISUB.LE.439)) THEN
          SQMQQ=SQM4
        ENDIF
        SQMQQR=SQRT(SQMQQ)
        IF(MSTP(145).EQ.1) THEN
           IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
     &          (ISUB.GE.431.AND.ISUB.LE.436)) THEN
              AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
              BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
              ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
              ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
              BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
              BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
           ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
     &             ISUB.GE.437) THEN
              AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
              BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
              ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
              ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
              BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
              BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
           ENDIF
           AQ2=AQ**2
           BQ2=BQ**2
           SMQQ2=SQMQQ*VINT(2)
C...Polarisation frames
           IF(MSTP(146).EQ.1) THEN
C...Recoil frame
              POLH1=SQRT(AQ2-SMQQ2)
              POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
              AZ=-SQMQQR/POLH1
              BZ=0D0
              AX=AQ*BQ/(POLH1*POLH2)
              BX=-POLH1/POLH2
           ELSEIF(MSTP(146).EQ.2) THEN
C...Gottfried Jackson frame
              POLH1=AQ+BQ
              POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
              AZ=SQMQQR/POLH1
              BZ=AZ
              AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
              BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
           ELSEIF(MSTP(146).EQ.3) THEN
C...Target frame
              POLH1=AQ-BQ
              POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
              AZ=-SQMQQR/POLH1
              BZ=-AZ
              AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
              BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
           ELSEIF(MSTP(146).EQ.4) THEN
C...Collins Soper frame
              POLH1=AQ2-BQ2
              POLH2=SQRT(VINT(2)*POLH1)
              AZ=-BQ/POLH2
              BZ=AQ/POLH2
              AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
              BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
           ENDIF
C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
           EL1K10=AZ*ATILK1+BZ*BTILK1
           EL1K20=AZ*ATILK2+BZ*BTILK2
           EL2K10=EL1K10
           EL2K20=EL1K20
           EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
           EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
           EL2K11=EL1K11
           EL2K21=EL1K21
        ENDIF
 
        IF(ISUB.EQ.421) THEN
C...g + g -> QQ~[3S11] + g
          IF(MSTP(145).EQ.0) THEN
*            FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
*     &            (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
            FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
     &            (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
*            FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
*     &           (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
          ELSE
            FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
            AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
            BB=2D0*(SH2+TH2)
            CC=2D0*(SH2+UH2)
            DD=2D0*SH2
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          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*PARP(IONIUM+1)
          ENDIF
 
        ELSEIF(ISUB.EQ.422) THEN
C...g + g -> QQ~[3S18] + g
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
     &            (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
     &            (SQMQQ*SQMQQR)*
     &            ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
          ELSE
            FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
     &            (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
            AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
            BB=2D0*(SH2+TH2)
            CC=2D0*(SH2+UH2)
            DD=2D0*SH2
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
          FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
          FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
          FACGGS=FACGG1+FACGG2+FACGG3
          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*PARP(IONIUM+2)*FACGG1/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=2
             SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=3
             SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
          ENDIF
 
        ELSEIF(ISUB.EQ.423) THEN
C...g + g -> QQ~[1S08] + g
          IF(MSTP(145).EQ.0) THEN
*            FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
*     &           (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
*     &           (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
*     &           (SHTH2*THUH2*UHSH2)
            FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
     &            (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
     &            TH2/(SHTH2*THUH2))*
     &            (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
          ELSE
            FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
     &            (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
     &            TH2/(SHTH2*THUH2))*
     &            (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
            IF(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FA
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
          FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
          FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
          FACGGS=FACGG1+FACGG2+FACGG3
          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*PARP(IONIUM+3)*FACGG1/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=2
             SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=3
             SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
          ENDIF
 
        ELSEIF(ISUB.EQ.424) THEN
C...g + g -> QQ~[3PJ8] + g
          POLY=SH2+SH*TH+TH2
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
     &            -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
     &            +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
     &            +7D0*TH**6)
     &            +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
     &            +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
     &            +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
     &            +35D0*TH**8)
     &            -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
     &            +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
     &            +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
     &            +84D0*TH**8)
     &            +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
     &            +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
     &            +451D0*SH*TH**5+126D0*TH**6)
     &            -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
     &            +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
     &            +171D0*SH*TH**5+42D0*TH**6)
     &            +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
     &            +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
     &            -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
     &            +99D0*SH*TH**3+35D0*TH**4)
     &            +7D0*SQMQQ**8*SHTH*POLY)/
     &            (SH*TH*UH*SQMQQR*SQMQQ*
     &            SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
          ELSE
            FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
     &            *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
            AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
     &           -SQMQQ*SHTH2*POLY**2*
     &           (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
     &           +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
     &           +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
     &           +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
     &           -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
     &           +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
     &           +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
     &           +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
     &           +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
     &           +145D0*SH*TH**5+34D0*TH**6)
     &           -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
     &           +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
     &           +44D0*TH**6)
     &           +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
     &           +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
     &           -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
     &           *(5D0*SH2+11D0*SH*TH+5D0*TH2)
     &           +3D0*SQMQQ**8*SHTH*POLY)
            BB=4D0*SHTH2*POLY**3
     &           *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
     &           -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
     &           +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
     &           +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
     &           +84D0*SH*TH**9+20D0*TH**10)
     &           +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
     &           +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
     &           +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
     &           +40D0*TH**8)
     &           -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
     &           -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
     &           -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
     &           +40D0*TH**8)
     &           +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
     &           -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
     &           -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
     &           -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
     &           -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
     &           +4D0*TH**6)
     &           -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
     &           +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
     &           +8D0*SQMQQ**7*SH*TH*SHTH*POLY
            CC=4D0*TH2*POLY**3
     &           *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
     &           -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
     &           +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
     &           +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
     &           +28D0*TH**9)
     &           +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
     &           -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
     &           +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
     &           +394D0*SH*TH**9+84D0*TH**10)
     &           -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
     &           +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
     &           +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
     &           +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
     &           +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
     &           +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
     &           -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
     &           +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
     &           +266D0*SH*TH**6+84D0*TH**7)
     &           +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
     &           -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
     &           +28D0*TH**6)
     &           -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
     &           +7D0*SH*TH**3+4*TH**4)
     &           +SQMQQ**8*SH*(SH-TH)**2*TH
            DD=2D0*TH2*SHTH2*POLY**3
     &           *(-SH2+2*SH*TH+2*TH2)
     &           +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
     &           +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
     &           -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
     &           -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
     &           -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
     &           +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
     &           -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
     &           -210D0*SH*TH**8-60D0*TH**9)
     &           +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
     &           +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
     &           -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
     &           -80D0*TH**8)
     &           -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
     &           +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
     &           -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
     &           +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
     &           +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
     &           -30D0*SH*TH**6-24D0*TH**7)
     &           -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
     &           +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
     &           -4D0*TH**6)
     &           +4D0*SQMQQ**7*SH*TH*SHTH*POLY
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in g g -> g g (recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
          FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
          FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
          FACGGS=FACGG1+FACGG2+FACGG3
          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*PARP(IONIUM+4)*FACGG1/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=2
             SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
             NCHN=NCHN+1
             ISIG(NCHN,1)=21
             ISIG(NCHN,2)=21
             ISIG(NCHN,3)=3
             SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
          ENDIF
 
        ELSEIF(ISUB.EQ.425) THEN
C...q + g -> q + QQ~[3S18]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
     &            (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
     &            (SQMQQ*SQMQQR*SH*UH*UHSH2)
          ELSE
            FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
     &            (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
            AA=SHTH2+THUH2
            BB=4D0
            CC=8D0
            DD=4D0
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
          FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
          FACQGS=FACQG1+FACQG2
          DO 2442 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
            DO 2441 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=2
              SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
 2441       CONTINUE
 2442     CONTINUE
 
        ELSEIF(ISUB.EQ.426) THEN
C...q + g -> q + QQ~[1S08]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
     &            (SH2+UH2)/(SQMQQR*TH*UHSH2)
          ELSE
            FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FA
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
          FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
          FACQGS=FACQG1+FACQG2
          DO 2444 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
            DO 2443 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=2
              SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
 2443       CONTINUE
 2444     CONTINUE
 
        ELSEIF(ISUB.EQ.427) THEN
C...q + g -> q + QQ~[3PJ8]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
     &            ((7D0*UHSH+8D0*TH)*(SH2+UH2)
     &            +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
     &            (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
          ELSE
            FF=10D0*PARU(1)*AS**3/
     &            (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
            AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
            BB=8D0*(SHTH2+TH*UH)
            CC=8D0*UHSH*(SHTH+THUH)
            DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
          FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
          FACQGS=FACQG1+FACQG2
          DO 2446 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
            DO 2445 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=2
              SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
 2445       CONTINUE
 2446     CONTINUE
 
        ELSEIF(ISUB.EQ.428) THEN
C...q + q~ -> g + QQ~[3S18]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
     &            (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
     &            (SQMQQ*SQMQQR*TH*UH*THUH2)
          ELSE
            FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
     &            (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
            AA=SHTH2+UHSH2
            BB=4D0
            CC=4D0
            DD=0D0
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=UH/TH-9D0/4D0*UH2/SH2
          FACGG2=TH/UH-9D0/4D0*TH2/SH2
          FACGGS=FACGG1+FACGG2
          DO 2447 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=2
            SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
 2447     CONTINUE
 
        ELSEIF(ISUB.EQ.429) THEN
C...q + q~ -> g + QQ~[1S08]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
     &            (TH2+UH2)/(SQMQQR*SH*THUH2)
          ELSE
            FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FA
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=UH/TH-9D0/4D0*UH2/SH2
          FACGG2=TH/UH-9D0/4D0*TH2/SH2
          FACGGS=FACGG1+FACGG2
          DO 2448 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=2
            SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
 2448     CONTINUE
 
        ELSEIF(ISUB.EQ.430) THEN
C...q + q~ -> g + QQ~[3PJ8]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
     &            ((7D0*THUH+8D0*SH)*(TH2+UH2)
     &            +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
     &            (SQMQQ*SQMQQR*SH*THUH2*THUH)
          ELSE
            FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
            AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
            BB=8D0*(UHSH2+SH*TH)
            CC=8D0*(SHTH2+SH*UH)
            DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
     &              +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
     &              +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
     &              +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
C...Split total contribution into different colour flows just like
C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
C...(recalculate kinematics for massless partons).
          THP=-0.5D0*SH*(1D0-CTH)
          UHP=-0.5D0*SH*(1D0+CTH)
          FACGG1=UH/TH-9D0/4D0*UH2/SH2
          FACGG2=TH/UH-9D0/4D0*TH2/SH2
          FACGGS=FACGG1+FACGG2
          DO 2449 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &            KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=2
            SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
 2449     CONTINUE
 
        ELSEIF(ISUB.EQ.431) THEN
C...g + g -> QQ~[3P01] + g
          PGTW=(SH*TH+TH*UH+UH*SH)/SH2
          QGTW=(SH*TH*UH)/SH**3
          RGTW=SQMQQ/SH
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*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)
          ELSE
            FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*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(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FC1
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FC1
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FC1
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FC1
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
          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*PARP(IONIUM+5)
          ENDIF
 
        ELSEIF(ISUB.EQ.432) THEN
C...g + g -> QQ~[3P11] + g
          PGTW=(SH*TH+TH*UH+UH*SH)/SH2
          QGTW=(SH*TH*UH)/SH**3
          RGTW=SQMQQ/SH
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*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
          ELSE
            FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
            C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
     &            +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
     &            -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
     &            +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
            C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
     &            -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
     &            *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
            C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
     &            -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
     &            *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
            C4=-4D0*THUH*(TH-UH)**2*
     &            (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
     &            -SH2*TH*UH*(TH2+UH2))
     &            +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
     &            -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
     &            +SH2*(5D0*THUH2-17D0*TH*UH)))
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
     &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          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*PARP(IONIUM+5)
          ENDIF
 
        ELSEIF(ISUB.EQ.433) THEN
C...g + g -> QQ~[3P21] + g
          PGTW=(SH*TH+TH*UH+UH*SH)/SH2
          QGTW=(SH*TH*UH)/SH**3
          RGTW=SQMQQ/SH
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*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)
          ELSE
            FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
     &            (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
            C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
     &            *SH*SH2**7
            C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
     &            +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
     &            +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
     &            +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
     &            +10D0*(SH2**2+TH2**2))
     &            +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
     &            -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
     &            -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
     &            +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
     &            +4D0*SH*TH*UH2**4*SHTH2)
            C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
     &            +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
     &            +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
     &            +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
     &            +10D0*(SH2**2+UH2**2))
     &            +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
     &            -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
     &            -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
     &            +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
     &            +4D0*SH*UH*TH2**4*UHSH2)
            C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
     &            -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
     &            +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
     &            -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
     &            -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
     &            -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
     &            +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
     &            -SH2**2*TH*UH*(114D0*TH**3*UH**3
     &            +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
     &            +3D0*(TH2**3+UH2**3)))
            C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
     &            *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
            C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
     &            *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
            C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
     &            +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
     &            +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
     &            82D0*TH**3)
     &            +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
     &            +45D0*TH**3)
     &            +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
     &            8D0*TH**3)
     &            +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
     &            +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
     &            +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
            C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
     &            +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
     &            +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
     &            82D0*UH**3)
     &            +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
     &            +45D0*UH**3)
     &            +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
     &            8D0*UH**3)
     &            +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
     &            +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
     &            +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
            C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
     &            +4D0*SH*TH2**2*UH2**2*THUH2
     &            -SH2*TH**3*UH**3*THUH*(TH2+UH2)
     &            -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
     &            +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
     &            +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
     &            +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
            C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
     &            -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
     &            -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
     &            -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
     &            +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
     &            +SH**5*TH*UH*(-428D0*TH**3*UH**3
     &            -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
     &            +2D0*(TH2**3+UH2**3))
     &            +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
     &            +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
     &            +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
     &            +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
            IF(MSTP(147).EQ.0) THEN
               FACQQG=1D0/3D0*(C1*3D0
     &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
     &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
     &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
     &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=C1*2D0
     &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
     &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
     &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K11*EL2K11)
     &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K21*EL2K21)
     &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
     &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
     &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
     &                  +EL1K20*EL2K20*EL1K11*EL2K11)
            ELSEIF(MSTP(147).EQ.2) THEN
               FACQQG=2D0*(C1
     &              -C2*EL1K11*EL2K11
     &              -C3*EL1K21*EL2K21
     &              -C4*EL1K11*EL2K21
     &              +C5*(EL1K11*EL2K11)**2
     &              +C6*(EL1K21*EL2K21)**2
     &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
     &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
     &              +(C9+C0)*(EL1K11*EL2K21)**2)
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          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*PARP(IONIUM+5)
          ENDIF
 
        ELSEIF(ISUB.EQ.434) THEN
C...q + g -> q + QQ~[3P01]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
     &            (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
          ELSE
            FA=-PARU(1)*AS**3*(16D0/243D0)*
     &            (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FA
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
          DO 2452 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
            DO 2451 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2451       CONTINUE
 2452     CONTINUE
 
        ELSEIF(ISUB.EQ.435) THEN
C...q + g -> q + QQ~[3P11]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
     &            (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
          ELSE
            FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
            C1=SH*UH
            C2=2D0*SH
            C3=0D0
            C4=2D0*(SH-UH)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
     &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          DO 2454 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
            DO 2453 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2453       CONTINUE
 2454     CONTINUE
 
        ELSEIF(ISUB.EQ.436) THEN
C...q + g -> q + QQ~[3P21]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
     &            ((6D0*SQMQQ**2+TH2)*UHSH2
     &            -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
     &            (SQMQQR*TH*UHSH2**2)
          ELSE
            FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
            C1=TH*UHSH2
            C2=4D0*(SH2+TH2+2D0*TH*UHSH)
            C3=4D0*UHSH2
            C4=8D0*SH*UHSH
            C5=8D0*TH
            C6=0D0
            C7=16D0*TH
            C8=0D0
            C9=-16D0*UHSH
            C0=16D0*SQMQQ
            IF(MSTP(147).EQ.0) THEN
               FACQQG=1D0/3D0*(C1*3D0
     &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
     &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
     &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
     &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=C1*2D0
     &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
     &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
     &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K11*EL2K11)
     &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K21*EL2K21)
     &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
     &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
     &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
     &                  +EL1K20*EL2K20*EL1K11*EL2K11)
            ELSEIF(MSTP(147).EQ.2) THEN
               FACQQG=2D0*(C1
     &              -C2*EL1K11*EL2K11
     &              -C3*EL1K21*EL2K21
     &              -C4*EL1K11*EL2K21
     &              +C5*(EL1K11*EL2K11)**2
     &              +C6*(EL1K21*EL2K21)**2
     &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
     &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
     &              +(C9+C0)*(EL1K11*EL2K21)**2)
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          DO 2456 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
            DO 2455 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2455       CONTINUE
 2456     CONTINUE
 
        ELSEIF(ISUB.EQ.437) THEN
C...q + q~ -> g + QQ~[3P01]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
     &            (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
          ELSE
            FA=PARU(1)*AS**3*(128D0/729D0)*
     &            (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
            IF(MSTP(147).EQ.0) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=COMFAC*2D0*FA
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=COMFAC*FA
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=0D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=0D0
            ENDIF
          ENDIF
          DO 2457 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2457     CONTINUE
 
        ELSEIF(ISUB.EQ.438) THEN
C...q + q~ -> g + QQ~[3P11]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
     &            (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
          ELSE
            FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
            C1=TH*UH
            C2=2D0*UH
            C3=2D0*TH
            C4=2D0*THUH
            IF(MSTP(147).EQ.0) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
            ELSEIF(MSTP(147).EQ.3) THEN
               FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
     &              +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.4) THEN
               FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ELSEIF(MSTP(147).EQ.5) THEN
               FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
     &              +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
            ELSEIF(MSTP(147).EQ.6) THEN
               FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
     &              +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          DO 2458 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2458     CONTINUE
 
        ELSEIF(ISUB.EQ.439) THEN
C...q + q~ -> g + QQ~[3P21]
          IF(MSTP(145).EQ.0) THEN
            FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
     &            ((6D0*SQMQQ**2+SH2)*THUH2
     &            -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
     &            (SQMQQR*SH*THUH2**2)
          ELSE
            FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
            C1=SH*THUH2
            C2=4D0*(SH2+UH2+2D0*SH*THUH)
            C3=4D0*(SH2+TH2+2D0*SH*THUH)
            C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
            C5=8D0*SH
            C6=C5
            C7=16D0*SH
            C8=C7
            C9=-16D0*THUH
            C0=16D0*SQMQQ
            IF(MSTP(147).EQ.0) THEN
               FACQQG=1D0/3D0*(C1*3D0
     &              -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
     &              +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
     &              +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
     &                     *(EL1K10*EL2K20-EL1K11*EL2K21)
     &              +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
     &                     *(EL1K20*EL2K20-EL1K21*EL2K21)
     &              +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
            ELSEIF(MSTP(147).EQ.1) THEN
               FACQQG=C1*2D0
     &              -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
     &              -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
     &              -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
     &              +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
     &              +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
     &              +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K11*EL2K11)
     &              +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
     &                      +EL1K10*EL2K20*EL1K21*EL2K21)
     &              +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
     &              +C0*(EL1K10*EL2K10*EL1K21*EL2K21
     &              +2D0*EL1K10*EL2K20*EL1K11*EL2K21
     &                  +EL1K20*EL2K20*EL1K11*EL2K11)
            ELSEIF(MSTP(147).EQ.2) THEN
               FACQQG=2D0*(C1
     &              -C2*EL1K11*EL2K11
     &              -C3*EL1K21*EL2K21
     &              -C4*EL1K11*EL2K21
     &              +C5*(EL1K11*EL2K11)**2
     &              +C6*(EL1K21*EL2K21)**2
     &              +C7*EL1K11*EL2K11*EL1K11*EL2K21
     &              +C8*EL1K21*EL2K21*EL1K11*EL2K21
     &              +(C9+C0)*(EL1K11*EL2K21)**2)
            ENDIF
            FACQQG=COMFAC*FF*FACQQG
          ENDIF
          DO 2459 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
 2459     CONTINUE
        ENDIF
C...QUARKONIA---
 
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGWZ
C...Subprocess cross sections for W/Z processes,
C...except that longitudinal WW scattering is in Higgs sector.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGWZ(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays and complex numbers
      DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
     &HL4(3),HR4(3)
      COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
 
C...Differential cross section expressions.
 
      IF(ISUB.LE.20) 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 100 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
            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))
  100     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 120 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
            IA=IABS(I)
            DO 110 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 110
              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
  110       CONTINUE
  120     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 130 I=1,MIN(16,MDCY(23,3))
            IDC=I+MDCY(23,2)-1
            IF(MDME(IDC,1).LT.0) GOTO 130
            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
  130     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 140 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
            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
  140     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 160 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
            DO 150 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
              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
  150       CONTINUE
  160     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 170 I=1,MIN(16,MDCY(23,3))
            IDC=I+MDCY(23,2)-1
            IF(MDME(IDC,1).LT.0) GOTO 170
            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
  170     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 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
            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
  180     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(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
            TERM2=RTCM(46)*(TH-UH)/(TH+UH)
            TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
     &      (4D0*SQMW))/(TH+UH)**2
          ENDIF
          DO 200 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
            DO 190 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
              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
              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
  190       CONTINUE
  200     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.40) THEN
        IF(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 220 I=1,6
            DO 210 J=1,3
              HGZ(I,J)=0D0
  210       CONTINUE
  220     CONTINUE
          RADC3=1D0+PYALPS(SQM3)/PARU(1)
          RADC4=1D0+PYALPS(SQM4)/PARU(1)
          DO 230 I=1,MIN(16,MDCY(23,3))
            IDC=I+MDCY(23,2)-1
            IF(MDME(IDC,1).LT.0) GOTO 230
            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
  230     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 240 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
  240     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 250 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
  250     CONTINUE
C...Loop over flavours; separate left- and right-handed couplings
          DO 270 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
            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 260 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)
  260       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)
  270     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 290 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
            DO 280 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 280
              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))
  280       CONTINUE
  290     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=DCMPLX(DBLE(COULP1),DBLE(COULP2))
              COULCP=DCMPLX(0D0,DBLE(COULP))
              COULCD=(COULCK+COULCP)/(COULCK-COULCP)
              COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
     &        (4D0*COULCP)*LOG(COULCD)
              COULCS=DCMPLX(0D0,0D0)
              NSTP=100
              DO 300 ISTP=1,NSTP
                COULXX=(ISTP-0.5)/NSTP
                COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
     &          (1D0+COULXX/COULCD))
  300         CONTINUE
              COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*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 310 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
            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(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
              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
            ELSE
              XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
              BET=SQRT(1D0-4D0*XMW02/SH)
              GAT=1D0/SQRT(1D0-BET**2)
              STHE2=1D0-CTH**2
              AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
              AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
     &        2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
              AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
     &        2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
     &        (1D0-2D0*BET*CTH+BET**2))
              PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
              PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
              A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
              A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
              A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
              ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
              ATOT=ATOT*CNN/SQMW*SH/BET*2D0
              DSIGWW=ATOT
            ENDIF
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACWW*FCOI*DSIGWW
  310     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 320 I=1,MIN(16,MDCY(23,3))
            IDC=I+MDCY(23,2)-1
            IF(MDME(IDC,1).LT.0) GOTO 320
            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
  320     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 340 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
            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 330 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACZQ
  330       CONTINUE
  340     CONTINUE
 
        ELSEIF(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 360 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
            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 350 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
  350       CONTINUE
  360     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 370 I=1,MIN(16,MDCY(23,3))
            IDC=I+MDCY(23,2)-1
            IF(MDME(IDC,1).LT.0) GOTO 370
            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
  370     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 390 I=MMINA,MMAXA
            IF(I.EQ.0) GOTO 390
            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 380 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACZQ*FZQN/FZQD
  380       CONTINUE
  390     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 410 I=MMINA,MMAXA
            IF(I.EQ.0) GOTO 410
            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 400 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
  400       CONTINUE
  410     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.100) THEN
        IF(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 420
          NCHN=NCHN+1
          ISIG(NCHN,1)=22
          ISIG(NCHN,2)=22
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACWW
  420     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 440 KCHW=1,-1,-2
            DO 430 ISDE=1,2
              IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
              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)
  430       CONTINUE
  440     CONTINUE
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGHG
C...Subprocess cross sections for Higgs processes,
C...except Higgs pairs in PYSGSU, but including WW scattering.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGHG(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      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/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
     &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
C...Local arrays and complex variables
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
      COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
      COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
 
C...Convert H or A process into equivalent h one
      IHIGG=1
      KFHIGG=25
      IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
         KFHIGG=KFPR(ISUB,1)
      END IF
      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
        IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
        IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
        IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
      ENDIF
      SQMH=PMAS(KFHIGG,1)**2
      GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
 
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=DBLE(HDTV*SH)
        A20L=-0.5D0*A00L
        A11L=A00L/6D0
        HDTLS=LOG(SH/PARP(44)**2)
        A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
     &  CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
     &  (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
        A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
     &  CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
     &  (20D0/9D0)*HDTLS),DBLE(PARU(1)))
        A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
     &  CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(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/(1D0-A004/A00L)
          A20U=A20L/(1D0-A204/A20L)
          A11U=A11L/(1D0-A114/A11L)
        ELSE
          A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
          A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
          A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
        ENDIF
      ENDIF
 
C...Differential cross section expressions.
 
      IF(ISUB.LE.60) THEN
        IF(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 100 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
            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
              IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
                HI=HI/(1D0+RMSS(41))**2
                IF(IHIGG.NE.3) THEN
                  HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
     &            PARU(151+10*IHIGG))**2
                ENDIF
              ENDIF
            ENDIF
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=HI*FACBW*HF
  100     CONTINUE
 
        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 120 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
            DO 110 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
              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
  110       CONTINUE
  120     CONTINUE
 
        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 140 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
            EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
            DO 130 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
              EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
              IF(EI*EJ.GT.0D0) GOTO 130
              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
  130       CONTINUE
  140     CONTINUE
 
        ELSEIF(ISUB.EQ.24) THEN
C...f + fbar -> Z0 + h0 (or H0, or A0)
C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
          HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
          CALL PYWIDT(23,SQM3,WDTP,WDTE)
          GMMZ3=SQRT(SQM3)*WDTP(0)
          HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
          HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
          CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
          GMMH4=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
          THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
          FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*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 150 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
            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)
  150     CONTINUE
 
        ELSEIF(ISUB.EQ.26) THEN
C...f + fbar' -> W+/- + h0 (or H0, or A0)
C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
          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=GMMH/((SQM4-SQMH)**2+GMMH**2)
          CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
          GMMH4=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
          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)*(HBW3C/HBW3)*(HBW4C/HBW4)
          FACHW=FACHW*WIDS(KFHIGG,2)
          IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
     &    PARU(155+10*IHIGG)**2
          DO 170 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
            DO 160 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 160
              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)
  160       CONTINUE
  170     CONTINUE
 
        ELSEIF(ISUB.EQ.32) THEN
C...f + g -> f + h0 (q + g -> q + h0 only)
          FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
C...H propagator: as simulated in PYOFSH and as desired
          SQMHC=PMAS(25,1)**2
          GMMHC=PMAS(25,1)*PMAS(25,2)
          HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
          CALL PYWIDT(25,SQM4,WDTP,WDTE)
          GMMHCC=SQRT(SQM4)*WDTP(0)
          HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
          FHCQ=FHCQ*HBW4C/HBW4
          DO 190 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.5) GOTO 190
            SQML=PYMRUN(IA,SH)**2
            SQMQ=PMAS(IA,1)**2
            FACHCQ=FHCQ*SQML/SQMW*
     &      (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
     &      2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
     &      (SQM4-SQMQ-SH)/SH)
            DO 180 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACHCQ*WIDS(25,2)
  180       CONTINUE
  190     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.80) THEN
        IF(ISUB.EQ.71) THEN
C...Z0 + Z0 -> Z0 + Z0
          IF(SH.LE.4.01D0*SQMZ) GOTO 220
 
          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 220
            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+2D0*A20U)**2
          ENDIF
          FACZZ=FACZZ*WIDS(23,1)
 
          DO 210 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI)
            VI=AI-4D0*EI*XWV
            AVI=AI**2+VI**2
            DO 200 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
              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
  200       CONTINUE
  210     CONTINUE
  220     CONTINUE
 
        ELSEIF(ISUB.EQ.72) THEN
C...Z0 + Z0 -> W+ + W-
          IF(SH.LE.4.01D0*SQMZ) GOTO 250
 
          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 250
            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 240 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
            EI=KCHG(IABS(I),1)/3D0
            AI=SIGN(1D0,EI)
            VI=AI-4D0*EI*XWV
            AVI=AI**2+VI**2
            DO 230 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
              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
  230       CONTINUE
  240     CONTINUE
  250     CONTINUE
 
        ELSEIF(ISUB.EQ.73) THEN
C...Z0 + W+/- -> Z0 + W+/-
          IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
 
          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 280
            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+3D0*A11U*DBLE(CTH))**2
          ENDIF
          FACZW=FACZW*WIDS(23,2)
 
          DO 270 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
            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 260 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
              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
  260       CONTINUE
  270     CONTINUE
  280     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 310
 
          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 310
            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 300 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
            EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
            DO 290 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
              EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
              IF(EI*EJ.GT.0D0) GOTO 290
              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)
  290       CONTINUE
  300     CONTINUE
  310     CONTINUE
 
        ELSEIF(ISUB.EQ.77) THEN
C...W+/- + W+/- -> W+/- + W+/-
          IF(SH.LE.4.01D0*SQMW) GOTO 340
 
          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 340
            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.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
            FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
          ENDIF
 
          DO 330 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
            EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
            DO 320 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
              EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
              IF(EI*EJ.LT.0D0) THEN
C...W+W-
                IF(MSTP(45).EQ.1) GOTO 320
                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 320
                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)
  320       CONTINUE
  330     CONTINUE
  340     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.120) THEN
        IF(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
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
          IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
            WDTP13=0D0
            DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
              IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
     &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
 345        CONTINUE
            IF(WDTP13.EQ.0D0) CALL PYERRM(26,
     &          '(PYSGHG:) did not find Higgs -> g g channel')  
            HI=SHR*WDTP13/32D0
          ELSE
            HI=SHR*WDTP(13)/32D0 
          ENDIF
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=HI*FACBW*HF
  350     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
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
          IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
            WDTP14=0D0
            DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
              IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
     &            KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
 355        CONTINUE
            IF(WDTP14.EQ.0D0) CALL PYERRM(26,
     &          '(PYSGHG:) did not find Higgs -> gamma gamma channel') 
            HI=SHR*WDTP14*2D0
          ELSE
            HI=SHR*WDTP(14)*2D0
          ENDIF
          IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
          NCHN=NCHN+1
          ISIG(NCHN,1)=22
          ISIG(NCHN,2)=22
          ISIG(NCHN,3)=1
          SIGH(NCHN)=HI*FACBW*HF
  360     CONTINUE
 
        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=DCMPLX(0D0,0D0)
          CIZTOT=DCMPLX(0D0,0D0)
          JMAX=3*MSTP(1)+1
          DO 370 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=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
              F1ALP=F0ALP**2
            ELSE
              F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
     &        -DBLE(0.5D0*PARU(1)))
              F1ALP=-F0ALP**2
            ENDIF
            F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
            IF(BBET.LT.1D0) THEN
              F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
              F1BET=F0BET**2
            ELSE
              F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
     &        -DBLE(0.5D0*PARU(1)))
              F1BET=-F0BET**2
            ENDIF
            F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
            IF(J.LE.3*MSTP(1)) THEN
              FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
     &        BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
              CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
              CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
            ELSE
              TXW=XW/XW1
              CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
     &        (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
     &        DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
              CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
     &        (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
     &        DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
     &        (F1BET-F1ALP))
            ENDIF
  370     CONTINUE
          CIGTOT=CIGTOT/DBLE(SH)
          CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
C...Loop over initial flavours
          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
            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(DBLE(EI)*CIGTOT+DBLE(VI)*
     &      CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
  380     CONTINUE
 
        ELSEIF(ISUB.EQ.111) THEN
C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
          IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
          CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
          IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
            WDTP13=0D0
            DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
              IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
     &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
 385        CONTINUE
            IF(WDTP13.EQ.0D0) CALL PYERRM(26,
     &          '(PYSGHG:) did not find Higgs -> g g channel')  
            FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
     &          (TH**2+UH**2)/(SH*SQM4)
          ELSE
            FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
     &          (TH**2+UH**2)/(SH*SQM4)
          ENDIF
C...Propagators: as simulated in PYOFSH and as desired
          HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
          GMMHC=SQRT(SQM4)*WDTP(0)
          HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
     &    ((SQM4-SQMH)**2+GMMHC**2)
          FACGH=FACGH*HBW4C/HBW4
          ELSE
C...Messy case: do full loop integrals
          A5STUR=0D0
          A5STUI=0D0
          DO 390 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))
  390     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)
          ENDIF
          DO 400 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACGH
  400     CONTINUE
 
        ELSEIF(ISUB.EQ.112) THEN
C...f + g -> f + h0 (q + g -> q + h0 only)
          IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
          CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
          IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
            WDTP13=0D0
            DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
              IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
     &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
 405        CONTINUE
            IF(WDTP13.EQ.0D0) CALL PYERRM(26,
     &          '(PYSGHG:) did not find Higgs -> g g channel')  
            FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
     &          (SH**2+UH**2)/(-TH*SQM4)
          ELSE
            FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
     &          (SH**2+UH**2)/(-TH*SQM4)
          ENDIF
C...Propagators: as simulated in PYOFSH and as desired
          HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
          GMMHC=SQRT(SQM4)*WDTP(0)
          HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
     &    ((SQM4-SQMH)**2+GMMHC**2)
          FACQH=FACQH*HBW4C/HBW4
          ELSE
C...Messy case: do full loop integrals
          A5TSUR=0D0
          A5TSUI=0D0
          DO 410 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))
  410     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)
          ENDIF
          DO 430 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
            DO 420 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACQH
  420       CONTINUE
  430     CONTINUE
 
        ELSEIF(ISUB.EQ.113) THEN
C...g + g -> g + h0
          IF(MSTP(38).NE.0) THEN
C...Simple case: only do gg <-> h exactly.
          CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
C...PS: Only use fixed-width when using SLHA decay table for this Higgs
          IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
            WDTP13=0D0
            DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
              IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
     &            KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
 435        CONTINUE
            IF(WDTP13.EQ.0D0) CALL PYERRM(26,
     &          '(PYSGHG:) did not find Higgs -> g g channel')  
            FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
     &          (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
          ELSE
            FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
     &          (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
          ENDIF
C...Propagators: as simulated in PYOFSH and as desired
          HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
          GMMHC=SQRT(SQM4)*WDTP(0)
          HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
     &    ((SQM4-SQMH)**2+GMMHC**2)
          FACGH=FACGH*HBW4C/HBW4
          ELSE
C...Messy case: do full loop integrals
          A2STUR=0D0
          A2STUI=0D0
          A2USTR=0D0
          A2USTI=0D0
          A2TUSR=0D0
          A2TUSI=0D0
          A4STUR=0D0
          A4STUI=0D0
          DO 440 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 440
            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
  440     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)
          ENDIF
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACGH
  450     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.170) THEN
        IF(ISUB.EQ.121) THEN
C...g + g -> Q + Qbar + h0
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
          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
            IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
              FACQQH=FACQQH/(1D0+RMSS(41))**2
              IF(IHIGG.NE.3) THEN
                FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
     &          PARU(151+10*IHIGG))**2
              ENDIF
            ENDIF
          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
  460     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
            IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
              FACQQH=FACQQH/(1D0+RMSS(41))**2
              IF(IHIGG.NE.3) THEN
                FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
     &          PARU(151+10*IHIGG))**2
              ENDIF
            ENDIF
          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 470 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQH*WTQQBH*FACBW
  470     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 490 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
            IA=IABS(I)
            DO 480 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
              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
  480       CONTINUE
  490     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 510 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
            EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
            DO 500 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
              EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
              IF(EI*EJ.GT.0D0) GOTO 500
              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
  500       CONTINUE
  510     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 530 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
            IA=IABS(I)
            IM=(MOD(IA,10)+1)/2
            DO 520 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
              JA=IABS(J)
              JM=(MOD(JA,10)+1)/2
              IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 520
              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
  520       CONTINUE
  530     CONTINUE
 
        ELSEIF(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
          Q2RM=SH
          IF(MSTP(32).EQ.12) Q2RM=PARP(194)
          DO 550 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.5) GOTO 550
            SQML=PYMRUN(IA,Q2RM)**2
            IUA=IA+MOD(IA,2)
            SQMQ=PYMRUN(IUA,Q2RM)**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 540 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
              IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
  540       CONTINUE
  550     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.402) THEN
        IF(ISUB.EQ.401) THEN
C...  g + g -> t + bbar + H-
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
          IA=KFPR(ISUBSV,2)
          CALL PYSTBH(WTTBH)
          CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=(1D0/PARU(1))*VINT(2)*HS/((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)=2d0*COMFAC*WTTBH*FACBW
c     Since we don't know yet if H+ or H-, assume H+
c     when calculating suppression due to closed channels.
          SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
          IF(ABS(WIDS(37,2)-WIDS(37,3))
     &       .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
     &       ABS(WIDS(6,2)-WIDS(6,3))
     &       .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
            WRITE(*,*)'Error: Process 401 cannot handle different'
            WRITE(*,*)'decays for H+ and H- or t and tbar.'
            WRITE(*,*)'Execution stopped.'
            CALL PYSTOP(108)
          END IF
 560      CONTINUE
 
        ELSEIF(ISUB.EQ.402) THEN
C...  q + qbar -> t + bbar + H-
          IA=KFPR(ISUBSV,2)
          CALL PYSTBH(WTTBH)
          CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
          IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
     &       FACBW=0D0
          DO 570 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &         KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
c     Since we don't know yet if H+ or H-, assume H+
c     when calculating suppression due to closed channels.
            SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
            IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
     &         .GE.1D-6.OR.
     &         ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
     &         .GE.1D-6) THEN
              WRITE(*,*)'Error: Process 402 cannot handle different'
              WRITE(*,*)'decays for H+ and H- or t and tbar.'
              WRITE(*,*)'Execution stopped.'
              CALL PYSTOP(108)
            END IF
 570      CONTINUE
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGSU
C...Subprocess cross sections for SUSY processes,
C...including Higgs pair production.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGSU(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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)
      COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
      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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
     &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
C...Local arrays and complex variables
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
      COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
      COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
      COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
 
CMRENNA++
C...Z and W width, combinations of weak mixing angle
      ZWID=PMAS(23,2)
      WWID=PMAS(24,2)
      TANW=SQRT(XW/XW1)
      CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
 
C...Convert almost equivalent SUSY processes into each other
C...Extract differences in flavours and couplings
 
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
          KFID=25
        ELSEIF(ISUB.EQ.300) THEN
          RKF=PARU(187)**2
          KFID=35
        ENDIF
        ISUB=213
C...H+ + H-
      ELSEIF(ISUB.EQ.301) THEN
        KFID=37
        RKF=1D0
        ISUB=201
      ENDIF
 
C...Supersymmetric processes - all of type 2 -> 2 :
C...correct final-state Breit-Wigners from fixed to running width.
      IF(MSTP(42).GT.0) THEN
        DO 100 I=1,2
        KFLW=KFPR(ISUBSV,I)
        KCW=PYCOMP(KFLW)
        IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
        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)
  100   CONTINUE
      ENDIF
 
C...Differential cross section expressions.
 
      IF(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 130 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
            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=(EI*EJ)**2*(POLL+POLR)
            TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
            TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
            TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/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 120 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 110 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)
  110           CONTINUE
  120         CONTINUE
              TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
     &        A2**2*TNN2**2*POLR)
              TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
     &        (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
              TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
     &        (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
              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*POLL+
     &        A2*TNN2*POLR)/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
  130     CONTINUE
 
        ELSEIF(ISUB.EQ.203) THEN
C...f + fbar -> e_L + e_Rbar
          DO 160 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
            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*POLL+XRF**2*POLR)*(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
            TNNA=0D0
            TNNB=0D0
            IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
              FAC2=SQRT(2D0)
              TNN1=0D0
              TNN2=0D0
              TNN3=0D0
              DO 150 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 140 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)
  140           CONTINUE
  150         CONTINUE
              TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
              TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
              TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
              TZN=(UH*TH-SQM3*SQM4)*A1*A2
              TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
              TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
     &        (1D0-SQMZ/SH)/SH
            ENDIF
            FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
            FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
            FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
C%%%%%%%%%%%
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=(FACQQ0+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)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
     &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
  160     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 180 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
            DO 170 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
              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
  170       CONTINUE
  180     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
          PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
          XLL=0.5D0
          XLR=0.0D0
          DO 190 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
            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)/PROPZ2*XLQ*XLL
            ENDIF
            FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
            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
  190     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
          FACXX=COMFAC*AEM**2/3D0/XW**2
          IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
          ZM12=SQM3
          ZM22=SQM4
          WU2 = (UH-ZM12)*(UH-ZM22)
          WT2 = (TH-ZM12)*(TH-ZM22)
          WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
          PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
          PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
          DO 200 I=1,4
            ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
            IF(IZID2.NE.IZID1) THEN
              ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
            ENDIF
  200     CONTINUE
          OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
     &    ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
          ORPP=DCONJG(OLPP)
          DO 210 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
            EI=KCHG(IABS(I),1)/3D0
            T3I=SIGN(1D0,EI+1D-6)/2D0
            XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
            XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
            GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
     &      DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
            GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
            QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
            QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
     &      /DCMPLX(TH-XML2)
            QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
            QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
     &      -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
            FCOL=1D0
            IF(IABS(I).GE.11) FCOL=3D0
            FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
     &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
     &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
     &      QRL*DCONJG(QRR)*POLR)*WS2
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACXX*FACGG1*FCOL
  210     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.230) THEN
        IF(ISUB.EQ.226) THEN
C...f + fbar -> ~chi+_1 + ~chi-_1
          FACXX=COMFAC*AEM**2/3D0
          ZM12=SQM3
          ZM22=SQM4
          WU2 = (UH-ZM12)*(UH-ZM22)
          WT2 = (TH-ZM12)*(TH-ZM22)
          WS2 = SMW(IZID1)*SMW(IZID2)*SH
          PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
          PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
          DIFF=0D0
          IF(IZID1.EQ.IZID2) DIFF=1D0
          DO 220 I=1,2
            VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
            UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
            IF(IZID2.NE.IZID1) THEN
              VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
              UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
            ENDIF
  220     CONTINUE
          OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
     &    VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
          ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
     &    UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
          DO 230 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
            EI=KCHG(IABS(I),1)/3D0
            T3I=SIGN(1D0,EI+1D-6)/2D0
            QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
            QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
            QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
            IF(MOD(I,2).EQ.0) THEN
              XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
              QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
     &        PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
     &        DCMPLX(T3I/XW/(TH-XML2))
            ELSE
              XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
              QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
     &        PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
     &        DCMPLX(T3I/XW/(TH-XML2))
            ENDIF
            FCOL=1D0
            IF(IABS(I).GE.11) FCOL=3D0
            FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
     &      (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
     &      2D0*DBLE(QLR*DCONJG(QLL)*POLL+
     &      QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*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
  230     CONTINUE
 
        ELSEIF(ISUB.EQ.229) THEN
C...q + qbar' -> ~chi0_1 + ~chi+-_1
          FACXX=COMFAC*AEM**2/6D0/XW**2
          ZM12=SQM3
          ZM22=SQM4
          WU2 = (UH-ZM12)*(UH-ZM22)
          WT2 = (TH-ZM12)*(TH-ZM22)
          WS2 = SMW(IZID1)*SMZ(IZID2)*SH
          RT2I = 1D0/SQRT(2D0)
          PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
     &    DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
          DO 240 I=1,2
            VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
            UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
  240     CONTINUE
          DO 250 I=1,4
            ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
  250     CONTINUE
          OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
     &    DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
          OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
     &    ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
 
          DO 270 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
            EI=KCHG(IA,1)/3D0
            T3I=SIGN(1D0,EI+1D-6)/2D0
            DO 260 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
              EJ=KCHG(JA,1)/3D0
              T3J=SIGN(1D0,EJ+1D-6)/2D0
              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
              IF(MOD(IA,2).EQ.0) THEN
                ZMI2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
                ZMJ2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
                QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
     &          TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
                QLR=OR-DCONJG(UMIXC(IZID1,1))*(
     &          ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
     &          /DCMPLX(TH-ZMJ2)
              ELSE
                ZMI2  = PMAS(PYCOMP(KSUSY1+JA),1)**2
                ZMJ2  = PMAS(PYCOMP(KSUSY1+IA),1)**2
                QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
     &          TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
                QLR=OR-DCONJG(UMIXC(IZID1,1))*(
     &          ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
     &          /DCMPLX(TH-ZMI2)
              ENDIF
              ZINTR=DBLE(QLR*DCONJG(QLL))
              FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
     &        2D0*ZINTR*WS2)
              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)
  260       CONTINUE
  270     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)
          ASYUK=RMSS(42)*AS
          FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
          GM2=SQM3
          ZM2=SQM4
          DO 280 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
            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)
  280     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 300 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
            DO 290 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
              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)
  290       CONTINUE
  300     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 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
            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 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
     &      XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
     &      (XMT**2+SH*SQM3)/SH/XST + (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 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
     &      XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
     &      (XMT**2+SH*SQM3)/SH/XST + (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)
  310     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 320
          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
  320     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 340 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
            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 330 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
              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)
  330       CONTINUE
  340     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 360 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
            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 350 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
              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)
  350       CONTINUE
  360     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
          ASYUK=RMSS(42)*AS
          FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
          FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
          KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
          DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
            IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
            IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
     &      WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
            DO 370 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
              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
  370       CONTINUE
  380     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 390 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
            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
  390     CONTINUE
 
        ELSEIF(ISUB.EQ.263) THEN
C...f + fbar -> ~t1 + ~t2bar
          DO 400 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
            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)
  400     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 410
          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
  410     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
          ASYUK=RMSS(42)*AS
          IF(ILR.EQ.1) THEN
            FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
            FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
            FACQQB=0.0D0
          ELSE
            FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
            FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
            FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
     &      XMT/XMU )
          ENDIF
          KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
          KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
          DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
            IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
              IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
              IF(I*J.LT.0) GOTO 420
              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
  420       CONTINUE
  430     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 )*RMSS(42)**2
            FACQQB=COMFAC*AS**2*4D0/9D0*(
     &      (UH*TH-SQM3*SQM4)/SH2 )
            FACQQI=-COMFAC*AS**2*4D0/27D0*(
     &      (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
            FACQQB=FACQQB+FACQQ1+FACQQI
          ELSE
            FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
            FACQQB=FACQQ1
          ENDIF
          KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
          KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
          DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
            IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
            KCHQ=2
            IF(I.LT.0) KCHQ=3
            DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
              IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
              IF(I*J.GT.0) GOTO 440
              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(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
     &        WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
  440       CONTINUE
  450     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 460 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
            IF(IA.EQ.KFNSQ) GOTO 460
            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)
  460     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 470
          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)
  470     CONTINUE
 
        ENDIF
      ENDIF
CMRENNA--
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGTC
C...Subprocess cross sections for Technicolor processes.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGTC(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      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/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
     &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays and complex variables
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
      COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
      COMPLEX*16 SSMX,DAAST,DZAST,DWAST
      COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
      COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
      COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
      COMPLEX*16 DVVS,DVVT,DVVU
      INTEGER INDX(6)
 
C...Combinations of weak mixing angle.
      TANW=SQRT(XW/XW1)
      CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
 
C...Convert almost equivalent technicolor processes into
C...a few basic processes, and set distinguishing parameters.
      IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
        SQTV=RTCM(12)**2
        SQTA=RTCM(13)**2
        SN2W=2D0*SQRT(XW*XW1)
        CS2W=1D0-2D0*XW
        CT2W=CS2W/SN2W
        CSXI=COS(ASIN(RTCM(3)))
        CSXIP=COS(ASIN(RTCM(4)))
        QUPD=2D0*RTCM(2)-1D0
        Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
        CAB2=0D0
        VOGP=0D0
        VRGP=0D0
        AOGP=0D0
        ARGP=0D0
        VXGP=0D0
        AXGP=0D0
        VAGP=0D0
        VZGP=0D0
        VWGP=0D0
C... rho_tc0, etc. -> W_L W_L, W_L W_T
        IF(ISUB.EQ.361) THEN
           KFA=24
           KFB=24
           CAB2=RTCM(3)**4
           AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
           ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
           VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
           AXGP = SQRT(2D0)*AXGP
           ARGP = SQRT(2D0)*ARGP
           VOGP = SQRT(2D0)*VOGP
C... rho_tc0 -> W_L pi_tc-
        ELSEIF(ISUB.EQ.362) THEN
           KFA=24
           KFB=KTECHN+211
           ISUB=361
           CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... pi_tc pi_tc
        ELSEIF(ISUB.EQ.363) THEN
           KFA=KTECHN+211
           KFB=KTECHN+211
           ISUB=361
           CAB2=(1D0-RTCM(3)**2)**2
C... rho_tc0/omega_tc -> gamma pi_tc
        ELSEIF(ISUB.EQ.364) THEN
           KFA=22
           KFB=KTECHN+111
           ISUB=361
           VOGP=CSXI/RTCM(12)
           VRGP=VOGP*QUPD
           VAGP=2D0*QUPD*CSXI
           VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
C... gamma pi_tc'
        ELSEIF(ISUB.EQ.365) THEN
           KFA=22
           KFB=KTECHN+221
           ISUB=361
           VRGP=CSXIP/RTCM(12)
           VOGP=VRGP*QUPD
           VAGP=2D0*Q2UD*CSXIP
           VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
C... Z pi_tc
        ELSEIF(ISUB.EQ.366) THEN
           KFA=23
           KFB=KTECHN+111
           ISUB=361
           VOGP=CSXI*CT2W/RTCM(12)
           VRGP=-QUPD*CSXI*TANW/RTCM(12)
           VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
           VZGP=-QUPD*CSXI*CS2W/XW1
C... Z pi_tc'
        ELSEIF(ISUB.EQ.367) THEN
           KFA=23
           KFB=KTECHN+221
           ISUB=361
C...RTCM(48) is the M_V for the techni-a
           VXGP=-CSXIP/SN2W/RTCM(48)
           VRGP=CSXIP*CT2W/RTCM(12)
           VOGP=-QUPD*CSXIP*TANW/RTCM(12)
           VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
           VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
C... W_T pi_tc
        ELSEIF(ISUB.EQ.368) THEN
           KFA=24
           KFB=KTECHN+211
           ISUB=361
C...RTCM(49) is the M_A for the techni-a
           AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
           VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
           ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
           VAGP=QUPD*CSXI/(2D0*SQRT(XW))
           VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
        ELSEIF(ISUB.EQ.370) THEN
           KFA=24
           KFB=23
           CAB2=RTCM(3)**4
           ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
           AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
C... W_L pi_tc0
        ELSEIF(ISUB.EQ.371) THEN
           KFA=24
           KFB=KTECHN+111
           ISUB=370
           CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... Z_L pi_tc+
        ELSEIF(ISUB.EQ.372) THEN
           KFA=KTECHN+211
           KFB=23
           ISUB=370
           CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
C... pi_tc+ pi_tc0
        ELSEIF(ISUB.EQ.373) THEN
           KFA=KTECHN+211
           KFB=KTECHN+111
           ISUB=370
           CAB2=(1D0-RTCM(3)**2)**2
C... gamma pi_tc+
        ELSEIF(ISUB.EQ.374) THEN
           KFA=KTECHN+211
           KFB=22
           ISUB=370
           VRGP=QUPD*CSXI/RTCM(12)
           VWGP=QUPD*CSXI/(2D0*SQRT(XW))
           AXGP=-CSXI/RTCM(49)
C... Z_T pi_tc+
        ELSEIF(ISUB.EQ.375) THEN
           KFA=KTECHN+211
           KFB=23
           ISUB=370
           VRGP=-QUPD*CSXI*TANW/RTCM(12)
           ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
           VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
           AXGP=-CSXI*CT2W/RTCM(49)
C... W_T pi_tc0
        ELSEIF(ISUB.EQ.376) THEN
           KFA=24
           KFB=KTECHN+111
           ISUB=370
           VRGP=0D0
           ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
           AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
C... W_T pi_tc0'
        ELSEIF(ISUB.EQ.377) THEN
           KFA=24
           KFB=KTECHN+221
           ISUB=370
           VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
           VWGP=CSXIP/(2D0*XW)
           VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
C... gamma W+
        ELSEIF(ISUB.EQ.378) THEN
           KFA=24
           KFB=22
           ISUB=370
           VRGP=QUPD*RTCM(3)/RTCM(12)
           AXGP=-RTCM(3)/RTCM(49)
C... gamma Z
        ELSEIF(ISUB.EQ.379) THEN
           KFA=23
           KFB=22
           ISUB=361
           VOGP=RTCM(3)/RTCM(12)
           VRGP=QUPD*RTCM(3)/RTCM(12)
        ELSEIF(ISUB.EQ.380) THEN
           KFA=23
           KFB=23
           ISUB=361
           VOGP=RTCM(3)*CT2W/RTCM(12)
           VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
        ENDIF
      ENDIF
 
C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
      IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
        IF(ITCM(5).LE.4) THEN
          SQDQQS=1D0/SH2
          SQDQQT=1D0/TH2
          SQDQQU=1D0/UH2
          SQDGGS=SQDQQS
          SQDGGT=SQDQQT
          SQDGGU=SQDQQU
          REDGGS=1D0/SH
          REDGGT=1D0/TH
          REDGGU=1D0/UH
          REDGTU=1D0/UH/TH
          REDGSU=1D0/SH/UH
          REDGST=1D0/SH/TH
          REDQST=1D0/SH/TH
          REDQTU=1D0/UH/TH
          SQDLGS=0D0
          SQDLGT=0D0
          SQDQTS=SQDQQS
        ELSEIF(ITCM(5).EQ.5) THEN
          TANT3=RTCM(21)
          IF(ITCM(2).EQ.0) THEN
            IMDL=1
          ELSE
            IMDL=2
          ENDIF
          ALPRHT=2.16D0*(3D0/ITCM(1))
          SIN2T=2D0*TANT3/(TANT3**2+1D0)
          SINT3=TANT3/SQRT(TANT3**2+1D0)
          XIG=SQRT(PYALPS(SH)/ALPRHT)
          X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
     &    RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
          X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
     &    RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
          X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
     &    SINT3**2)*2D0/SIN2T
          X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
     &    SINT3**2)*2D0/SIN2T
 
          SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
          SM1112=X12*RTCM(28)**2*SIN2T
          SM1121=-X21*RTCM(28)**2*SIN2T
          SM2212=-SM1112
          SM2221=-SM1121
          SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
     &    (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
 
C.........SH LOOP
          ZTC(1,1)=DCMPLX(SH,0D0)
          CALL PYWIDT(3100021,SH,WDTP,WDTE)
          IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
          ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
          CALL PYWIDT(3100113,SH,WDTP,WDTE)
          ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
          CALL PYWIDT(3400113,SH,WDTP,WDTE)
          ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
          CALL PYWIDT(3200113,SH,WDTP,WDTE)
          ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
          CALL PYWIDT(3300113,SH,WDTP,WDTE)
          ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
          ZTC(1,2)=(0D0,0D0)
          ZTC(1,3)=DCMPLX(SH*XIG,0D0)
          ZTC(1,4)=ZTC(1,3)
          ZTC(1,5)=ZTC(1,2)
          ZTC(1,6)=ZTC(1,2)
          ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
          ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
          ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
          ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
          ZTC(3,4)=-SM1122
          ZTC(3,5)=-SM1112
          ZTC(3,6)=-SM1121
          ZTC(4,5)=-SM2212
          ZTC(4,6)=-SM2221
          ZTC(5,6)=-SM1221
 
          DO 110 I=1,5
            DO 100 J=I+1,6
               ZTC(J,I)=ZTC(I,J)
  100       CONTINUE
  110     CONTINUE
          CALL PYLDCM(ZTC,6,6,INDX,D)
          DO 130 I=1,6
            DO 120 J=1,6
             YTC(I,J)=(0D0,0D0)
              IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
  120       CONTINUE
  130     CONTINUE
 
          DO 140 I=1,6
            CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
  140     CONTINUE
          DGGS=YTC(1,1)
          DVVS=YTC(2,2)
          DGVS=YTC(1,2)
 
          XIG=SQRT(PYALPS(-TH)/ALPRHT)
C.........TH LOOP
          ZTC(1,1)=DCMPLX(TH)
          ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
          ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
          ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
          ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
          ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
          ZTC(1,2)=(0D0,0D0)
          ZTC(1,3)=DCMPLX(TH*XIG,0D0)
          ZTC(1,4)=ZTC(1,3)
          ZTC(1,5)=ZTC(1,2)
          ZTC(1,6)=ZTC(1,2)
          ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
          ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
          ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
          ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
          ZTC(3,4)=-SM1122
          ZTC(3,5)=-SM1112
          ZTC(3,6)=-SM1121
          ZTC(4,5)=-SM2212
          ZTC(4,6)=-SM2221
          ZTC(5,6)=-SM1221
          DO 160 I=1,5
            DO 150 J=I+1,6
               ZTC(J,I)=ZTC(I,J)
  150       CONTINUE
  160     CONTINUE
          CALL PYLDCM(ZTC,6,6,INDX,D)
          DO 180 I=1,6
            DO 170 J=1,6
              YTC(I,J)=(0D0,0D0)
              IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
  170       CONTINUE
  180     CONTINUE
          DO 190 I=1,6
            CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
  190     CONTINUE
          DGGT=YTC(1,1)
          DVVT=YTC(2,2)
          DGVT=YTC(1,2)
 
          XIG=SQRT(PYALPS(-UH)/ALPRHT)
C.........UH LOOP
          ZTC(1,1)=DCMPLX(UH,0D0)
          ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
          ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
          ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
          ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
          ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
          ZTC(1,2)=(0D0,0D0)
          ZTC(1,3)=DCMPLX(UH*XIG,0D0)
          ZTC(1,4)=ZTC(1,3)
          ZTC(1,5)=ZTC(1,2)
          ZTC(1,6)=ZTC(1,2)
          ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
          ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
          ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
          ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
          ZTC(3,4)=-SM1122
          ZTC(3,5)=-SM1112
          ZTC(3,6)=-SM1121
          ZTC(4,5)=-SM2212
          ZTC(4,6)=-SM2221
          ZTC(5,6)=-SM1221
          DO 210 I=1,5
            DO 200 J=I+1,6
               ZTC(J,I)=ZTC(I,J)
  200       CONTINUE
  210     CONTINUE
          CALL PYLDCM(ZTC,6,6,INDX,D)
          DO 230 I=1,6
            DO 220 J=1,6
              YTC(I,J)=(0D0,0D0)
              IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
  220       CONTINUE
  230     CONTINUE
          DO 240 I=1,6
            CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
  240     CONTINUE
          DGGU=YTC(1,1)
          DVVU=YTC(2,2)
          DGVU=YTC(1,2)
 
          IF(IMDL.EQ.1) THEN
            DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
            DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
            DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
            DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
            DQGS=DGGS-DGVS*DCMPLX(TANT3)
            DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
          ELSE
            DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
            DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
            DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
            DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
            DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
            DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
          ENDIF
 
          SQDQTS=ABS(DQTS)**2
          SQDQQS=ABS(DQQS)**2
          SQDQQT=ABS(DQQT)**2
          SQDQQU=ABS(DQQU)**2
          SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
          REDLGS=DBLE(DQGS)
          SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
          REDHGS=DBLE(DTGS)
          SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
 
          SQDGGS=ABS(DGGS)**2
          SQDGGT=ABS(DGGT)**2
          SQDGGU=ABS(DGGU)**2
          REDGGS=DBLE(DGGS)
          REDGGT=DBLE(DGGT)
          REDGGU=DBLE(DGGU)
          REDGTU=DBLE(DGGU*DCONJG(DGGT))
          REDGSU=DBLE(DGGU*DCONJG(DGGS))
          REDGST=DBLE(DGGS*DCONJG(DGGT))
          REDQST=DBLE(DQQS*DCONJG(DQQT))
          REDQTU=DBLE(DQQT*DCONJG(DQQU))
        ENDIF
      ENDIF
 
 
C...Differential cross section expressions.
 
      IF(ISUB.LE.190) THEN
        IF(ISUB.EQ.149) THEN
C...g + g -> eta_tc
          KCTC=PYCOMP(KTECHN+331)
          CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
          IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
          HP=SH
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
          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
  250     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 260 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
            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((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
              FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
     &        (AEM*RTCM(41)**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((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
     &      MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
  260     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*RTCM(41)**4)
          KFF=IABS(KFPR(ISUB,1))
          FCOF=1D0
          IF(KFF.LE.10) FCOF=3D0
          DO 280 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
            IA=IABS(I)
            DO 270 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 270
              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((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
     &        SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
  270       CONTINUE
  280     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.200) THEN
        IF(ISUB.EQ.191) THEN
C...q + qbar -> rho_tc0.
          KCTC=PYCOMP(KTECHN+113)
          SQMRHT=PMAS(KCTC,1)**2
          CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
          IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
          HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          ALPRHT=2.16D0*(3D0/ITCM(1))
          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 290 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
            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
  290     CONTINUE
 
        ELSEIF(ISUB.EQ.192) THEN
C...q + qbar' -> rho_tc+/-.
          KCTC=PYCOMP(KTECHN+213)
          SQMRHT=PMAS(KCTC,1)**2
          CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
          IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
          ALPRHT=2.16D0*(3D0/ITCM(1))
          HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
     &    (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
          DO 310 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
            IA=IABS(I)
            DO 300 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 300
              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
  300       CONTINUE
  310     CONTINUE
 
        ELSEIF(ISUB.EQ.193) THEN
C...q + qbar -> omega_tc0.
          KCTC=PYCOMP(KTECHN+223)
          SQMOMT=PMAS(KCTC,1)**2
          CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
          IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
          HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          ALPRHT=2.16D0*(3D0/ITCM(1))
          HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
     &    (2D0*RTCM(2)-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 320 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
            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
  320     CONTINUE
 
        ELSEIF(ISUB.EQ.194) THEN
C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
C...Default final state is e+e-
          KFA=KFPR(ISUBSV,1)
          ALPRHT=2.16D0*(3D0/ITCM(1))
          HP=AEM**2*COMFAC

          SN2W=2D0*SQRT(XW*XW1)
C          TANW=SQRT(PARU(102)/(1D0-PARU(102)))
C          CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
 
          QUPD=2D0*RTCM(2)-1D0
          FAR=SQRT(AEM/ALPRHT)
          FAO=FAR*QUPD
          FZR=FAR*CT2W
          FZO=-FAO*TANW
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
          FZX=-FAR/SN2W*RTCM(47)
          SFAR=FAR**2
          SFAO=FAO**2
          SFZR=FZR**2
          SFZO=FZO**2
          SFZX=FZX**2
          CALL PYWIDT(23,SH,WDTP,WDTE)
          SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
          SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
          SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
          SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
C...Propagator including a_T^0
          DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
     $    SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
C...Add in techni-a contribution
          DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
          DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
     $     SFZX*SSMR*SSMO)/DETD/SH
          DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
          DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
 
          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*DCMPLX(XWRHT,0D0)
          DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
 
          DO 330 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
            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
  330     CONTINUE
 
        ELSEIF(ISUB.EQ.195) THEN
C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
          KFA=KFPR(ISUBSV,1)
          KFB=KFA+1
          ALPRHT=2.16D0*(3D0/ITCM(1))
          FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
 
          FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
C
C...Propagator including a_T^+
          FWX=-FWR*RTCM(47)
          CALL PYWIDT(24,SH,WDTP,WDTE)
          SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
          SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
          SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
          DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
     &     DCMPLX(FWX**2,0D0)*SSMR
          DWW=SSMR*SSMX/DETD/SH
          FCOF=1D0
          IF(KFA.LE.8) FCOF=3D0
          HP=FACTC*ABS(DWW)**2*FCOF
 
          DO 350 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
            IA=IABS(I)
            DO 340 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 340
              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)
  340       CONTINUE
  350     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.380) THEN
        ALPRHT=2.16D0*(3D0/ITCM(1))
        IF(ISUB.EQ.361) THEN
          FAR=SQRT(AEM/ALPRHT)
          FAO=FAR*QUPD
          FZR=FAR*CT2W
          FZO=-FAO*TANW
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
          FZX=-FAR/SN2W*RTCM(47)
          SFAR=FAR**2
          SFAO=FAO**2
          SFZR=FZR**2
          SFZO=FZO**2
          SFZX=FZX**2
          CALL PYWIDT(23,SH,WDTP,WDTE)
          SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
          SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
          SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
          SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),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
C...Add in techni-a contribution
          DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
          DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
     $     SFZX*FAR*SSMO)/DETD/SH
          DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
          DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
     $     SFZX*FAO*SSMR)/DETD/SH
          DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
          DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
          DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
          DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
     $     SFZX*SSMR*SSMO)/DETD/SH
          DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
          DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
 
C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
C...W+W-, W pi_tc, pi_T pi_T, etc.
          FACA=(SH**2*BE34**2-(TH-UH)**2)
          VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
          AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
          FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
          HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH 
          DO 370 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
            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) ! = \zeta_{iL} in PRD67-115011
            VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
C...........Eqs. (5) and (6) in LSTC-rates.pdf
            F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
            F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
            F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
            F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
     $                    VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
            F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
            F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
            F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
            F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
     $                    VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
            HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
C...........Eqs. (5) and (7) in LSTC-rates.pdf
            F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
            F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
            F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
            F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
            F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
            F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
            HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
C
C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
C
c$$$            F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
c$$$     $      VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
c$$$            F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
c$$$     $      VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
            F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
            F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
            HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
            HI=HI+HJ+HK
            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(PYCOMP(KFA),1)
            ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
               SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=-I
               ISIG(NCHN,3)=2
               SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
            ELSE 
               SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
            ENDIF
  370     CONTINUE
 
        ELSEIF(ISUB.EQ.370) THEN
C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
C...f + fbar' -> gamma pi_tc, etc.
          FACA=(SH**2*BE34**2-(TH-UH)**2)
          FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
          VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
          AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
          ALPRHT=2.16D0*(3D0/ITCM(1))
          FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
          FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
          FWX=-FWR*RTCM(47)
          CALL PYWIDT(24,SH,WDTP,WDTE)
          SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
          SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
          CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
          SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
          DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
     &     DCMPLX(FWX**2,0D0)*SSMR
          DWW=SSMR*SSMX/DETD/SH
          DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
          DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
          HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
     $    VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
C
C...........Eq. (25) in PRD67-115011 with DWW term dropped.
C
c$$$          HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
          HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
C...Add in W_L Z_T axial and vector contributions.
          IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
     $    (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)*     !AFAC w/ switched masses.
     $    ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
     $    VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
          DO 410 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
            IA=IABS(I)
            DO 400 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 400
              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
              IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
                SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
              ELSE
                SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
     &          WIDS(PYCOMP(KFB),2)
              ENDIF
  400       CONTINUE
  410     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.390) THEN
        IF(ISUB.EQ.381) THEN
C...f + f' -> f + f' (g exchange)
          FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
          FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
     &    MSTP(34)*2D0/3D0*UH2*REDQST)
          FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
          FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
          RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
          IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
C...Modifications from contact interactions (compositeness)
            FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
            FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
     &      (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
            FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
     &      (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
            FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
            RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
          ELSEIF(ITCM(5).EQ.5) THEN
            FACCI1=FACQQ1
            FACCIB=FACQQB
            FACCI2=FACQQ2
            FACCI3=FACQQ1
CSM.......Check this change from
CSM            RATCII=1D0
            RATCII=RATQQI
          ENDIF
          DO 430 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
            DO 420 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=J
              ISIG(NCHN,3)=1
              IF(ITCM(5).LE.0.OR.(ITCM(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(ITCM(5).LE.0.OR.(ITCM(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
  420       CONTINUE
  430     CONTINUE
 
        ELSEIF(ISUB.EQ.382) THEN
C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
          CALL PYWIDT(21,SH,WDTP,WDTE)
          FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
          FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          IF(ITCM(5).EQ.1) THEN
C...Modifications from contact interactions (compositeness)
            FACCIB=FACQQB
            DO 440 I=1,2
              FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
     &        WDTE(I,2)+WDTE(I,4))
  440       CONTINUE
          ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
            FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
     &      (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          ELSEIF(ITCM(5).EQ.5) THEN
            FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
     &      WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
            FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
          ENDIF
          DO 450 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
              SIGH(NCHN)=FACQQB
            ELSEIF(ITCM(5).EQ.5) THEN
              SIGH(NCHN)=FACQQB
              NCHN=NCHN+1
              ISIG(NCHN,1)=I
              ISIG(NCHN,2)=-I
              ISIG(NCHN,3)=2
              SIGH(NCHN)=FACCIB
            ELSE
              SIGH(NCHN)=FACCIB
            ENDIF
  450     CONTINUE
 
        ELSEIF(ISUB.EQ.383) 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+9D0/4D0*TH*UH/SH2*SQDLGS)
          FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
     &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
          IF(ITCM(5).EQ.5) THEN
            FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
     &      UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
            FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
     &      TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
          ENDIF
          DO 460 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=0.5D0*FACGG1
            IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=2
            SIGH(NCHN)=0.5D0*FACGG2
            IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
  460     CONTINUE
 
        ELSEIF(ISUB.EQ.384) 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-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
          FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
     &    SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
          DO 480 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
            DO 470 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
              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
  470       CONTINUE
  480     CONTINUE
 
        ELSEIF(ISUB.EQ.385) THEN
C...g + g -> f + fbar (g + g -> q + qbar only)
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
          IDC0=MDCY(21,2)-1
C...Begin by d, u, s flavours.
          FLAVWT=0D0
          IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
          IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
          IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
     &    SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
          FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
     &    UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
          FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
     &    TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
          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
C...Next c and b flavours: modified that and uhat for fixed
C...cos(theta-hat).
          DO 490 IFL=4,5
          SQMAVG=PMAS(IFL,1)**2
          IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
            BE34=SQRT(1D0-4D0*SQMAVG/SH)
            THQ=-0.5D0*SH*(1D0-BE34*CTH)
            UHQ=-0.5D0*SH*(1D0+BE34*CTH)
            THUHQ=THQ*UHQ-SQMAVG*SH
            IF(MSTP(34).EQ.0) THEN
              FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
              FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
            ELSE
              FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
              FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &        UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
            ENDIF
            IF(ITCM(5).GE.5) THEN
              IF(IFL.EQ.4) THEN
                FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
     &          2.25D0*THQ*UHQ/SH2*SQDLGS
                FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
     &          2.25D0*THQ*UHQ/SH2*SQDLGS
              ELSE
                FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
     &          2.25D0*THQ*UHQ/SH2*SQDHGS
                FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
     &          2.25D0*THQ*UHQ/SH2*SQDHGS
              ENDIF
            ENDIF
            FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
            FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=1+2*(IFL-3)
            SIGH(NCHN)=FACQQ1
            NCHN=NCHN+1
            ISIG(NCHN,1)=21
            ISIG(NCHN,2)=21
            ISIG(NCHN,3)=2+2*(IFL-3)
            SIGH(NCHN)=FACQQ2
          ENDIF
  490     CONTINUE
  500     CONTINUE
 
        ELSEIF(ISUB.EQ.386) THEN
C...g + g -> g + g
          IF(ITCM(5).LE.4) THEN
            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)
          ELSE
            GST=  (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
     &      16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
     &      4D0*REDGST*(SH + 2D0*TH)*
     &      (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
     &      2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
     &      2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
     &      32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
     &      SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
     &      96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
            GSU=  (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
     &      16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
     &      4D0*REDGSU*(SH + 2D0*UH)*
     &      (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
     &      2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
     &      2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
     &      32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
     &      SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
     &      96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
            GUT=  (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
     &      4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
     &      58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
     &      4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
     &      48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
     &      4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
     &      72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
     &      4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
     &      72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
     &      2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
     &      30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
     &      SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
     &      52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
            FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
            FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
            FACGG3=COMFAC*AS**2*9D0/4D0*GUT
          ENDIF
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
          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
  510     CONTINUE
 
        ELSEIF(ISUB.EQ.387) THEN
C...q + qbar -> Q + Qbar
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
     &    2D0*SQMAVG/SH)
          IF(ITCM(5).GE.5) THEN
            IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
              FACQQB=FACQQB*SH2*SQDQTS
            ELSE
              FACQQB=FACQQB*SH2*SQDQQS
            ENDIF
          ENDIF
          IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,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 520 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACQQB
  520     CONTINUE
 
        ELSEIF(ISUB.EQ.388) THEN
C...g + g -> Q + Qbar
          SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
          THQ=-0.5D0*SH*(1D0-BE34*CTH)
          UHQ=-0.5D0*SH*(1D0+BE34*CTH)
          THUHQ=THQ*UHQ-SQMAVG*SH
          IF(MSTP(34).EQ.0) THEN
            FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
            FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
          ELSE
            FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &      THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
            FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
     &      UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
          ENDIF
          IF(ITCM(5).GE.5) THEN
            IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
              FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
     &        2.25D0*THQ*UHQ/SH2*SQDHGS
              FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
     &        2.25D0*THQ*UHQ/SH2*SQDHGS
            ELSE
              FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
     &        2.25D0*THQ*UHQ/SH2*SQDLGS
              FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
     &        2.25D0*THQ*UHQ/SH2*SQDLGS
            ENDIF
          ENDIF
          FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
          FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
          IF(MSTP(35).GE.1) THEN
            FATRE=PYHFTH(SH,SQMAVG,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 530
          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
  530     CONTINUE
        ENDIF
      ENDIF
 
CMRENNA--
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSGEX
C...Subprocess cross sections for assorted exotic processes,
C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
C...Auxiliary to PYSIGH.
 
      SUBROUTINE PYSGEX(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      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/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
     &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
C...Local arrays
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
 
C...Differential cross section expressions.
 
      IF(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 100 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
            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
C...Special case: if only branching ratios known then use them.
            IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
              HI=0D0
              IF(IA.LT.10) THEN
                HI=SHR*WDTP(IA)*FACA/9D0
              ELSEIF(IA.LT.20) THEN
                HI=SHR*WDTP(IA-2)
              ENDIF
              HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
              SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
            ELSE
C...Normal cross section.
              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))
            ENDIF
  100     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 120 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
            IA=IABS(I)
            DO 110 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 110
              KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
C...Special case: if only branching ratios known then use them.
              IF(MWID(34).EQ.2) THEN
                HI=0D0
                DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
                  IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
     &            IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
     &            .AND.JA.EQ.IABS(KFDP(IDC,1))))
     &             HI=SHR*WDTP(IDC+1-MDCY(34,2))
  105           CONTINUE
                IF(IA.LT.10) HI=HI*FACA/9D0
              ELSE
C...Normal cross section.
                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
              ENDIF 
              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
  110       CONTINUE
  120     CONTINUE
 
        ELSEIF(ISUB.EQ.144) THEN
C...f + fbar' -> R
          SQMR=PMAS(41,1)**2
          CALL PYWIDT(41,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
          HP=AEM/(12D0*XW)*SH
          DO 140 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
            IA=IABS(I)
            DO 130 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
              JA=IABS(J)
              IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
              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
  130       CONTINUE
  140     CONTINUE
 
        ELSEIF(ISUB.EQ.145) THEN
C...q + l -> LQ (leptoquark)
          SQMLQ=PMAS(42,1)**2
          CALL PYWIDT(42,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
          IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
          HP=AEM/4D0*SH
          KFLQQ=KFDP(MDCY(42,2),1)
          KFLQL=KFDP(MDCY(42,2),2)
          DO 160 I=MMIN1,MMAX1
            IF(KFAC(1,I).EQ.0) GOTO 160
            IA=IABS(I)
            IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
            DO 150 J=MMIN2,MMAX2
              IF(KFAC(2,J).EQ.0) GOTO 150
              JA=IABS(J)
              IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
              IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
              IF(JA.EQ.IA) GOTO 150
              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
  150       CONTINUE
  160     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=-RTCM(43)/2D0-RTCM(44)/2D0
          FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
          IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
     &    FACBW=0D0
          HP=SH
          DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
            DO 170 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
              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
  170       CONTINUE
  180     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*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
          IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
     &    FACBW=0D0
          HP=SH
          DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
            DO 190 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
              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
  190       CONTINUE
  200     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.190) THEN
        IF(ISUB.EQ.162) THEN
C...q + g -> LQ + lbar; LQ=leptoquark
          SQMLQ=PMAS(42,1)**2
          FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
     &    (UH2+SQMLQ**2)/(UH-SQMLQ)**2
          KFLQQ=KFDP(MDCY(42,2),1)
          DO 220 I=MMINA,MMAXA
            IF(IABS(I).NE.KFLQQ) GOTO 220
            KCHLQ=ISIGN(1,I)
            DO 210 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
  210       CONTINUE
  220     CONTINUE
 
        ELSEIF(ISUB.EQ.163) THEN
C...g + g -> LQ + LQbar; LQ=leptoquark
          SQMLQ=PMAS(42,1)**2
          FACLQ=COMFAC*FACA*WIDS(42,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 230
          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
  230     CONTINUE
 
        ELSEIF(ISUB.EQ.164) THEN
C...q + qbar -> LQ + LQbar; LQ=leptoquark
          DELTA=0.25D0*(SQM3-SQM4)**2/SH
          SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
          TH=TH-DELTA
          UH=UH-DELTA
C          SQMLQ=PMAS(42,1)**2
          FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
     &    (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
          FACLQS=COMFAC*WIDS(42,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(42,2),1)
          DO 240 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
            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
  240     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/RTCM(41)**2)**2*(1D0-SQM4/SH)
          FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**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
C...Branching ratios.
          BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
          BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
          DO 260 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
            DO 250 J=MMIN2,MMAX2
              JA=IABS(J)
              IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
              IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=1
                IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
                IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=2
                IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
                IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
              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
                IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
                IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
              ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=1
                IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
                IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=2
                IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
                IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
              ELSEIF(I.EQ.-J) THEN
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=1
                IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
                IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
                NCHN=NCHN+1
                ISIG(NCHN,1)=I
                ISIG(NCHN,2)=J
                ISIG(NCHN,3)=2
                IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
                IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
              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
                IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
                IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
              ENDIF
  250       CONTINUE
  260     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/12D0)*(SH/RTCM(41)**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
C...Branching ratios.
          BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
          BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
          DO 270 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
            J=-I
            JA=IABS(J)
            IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=J
            ISIG(NCHN,3)=1
            IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
            IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=J
            ISIG(NCHN,3)=2
            IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
            IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
  270     CONTINUE
        ENDIF
 
      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)
          KFREC=PYCOMP(KFRES)
          CALL PYWIDT(KFRES,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
          DO 290 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 290
            DO 280 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 280
              IF(I*J.LT.0) GOTO 280
              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
  280       CONTINUE
  290     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)
          KFREC=PYCOMP(KFRES)
C...Propagators: as simulated in PYOFSH and as desired
          HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
     &    (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
          CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
          GMMC=SQRT(SQM3)*WDTP(0)
          HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
          FHCC=COMFAC*AEM*HBW3C/HBW3
          DO 310 I=MMINA,MMAXA
            IA=IABS(I)
            IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
            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 300 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
              IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=22
              ISIG(NCHN,3)=0
              SIGH(NCHN)=FHCC*SMM*WIDSC
  300       CONTINUE
  310     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)
          KFREC=PYCOMP(KFRES)
          SQMH=PMAS(KFREC,1)**2
          GMMH=PMAS(KFREC,1)*PMAS(KFREC,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 320 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
            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
  320     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)
          KFREC=PYCOMP(KFRES)
          SQMH=PMAS(KFREC,1)**2
          IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
          IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
     &    PMAS(PYCOMP(9900024),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(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
     &    FACBW=0D0
          DO 340 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
            IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
            KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
            DO 330 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
              IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
              KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
              KCHH=KCHWI+KCHWJ
              IF(IABS(KCHH).NE.2) GOTO 330
              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
  330       CONTINUE
  340     CONTINUE
 
        ELSEIF(ISUB.EQ.353) THEN
C...f + fbar -> Z_R0
          SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
          CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
          HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
          DO 350 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
            IF(IABS(I).LE.8) THEN
              EI=KCHG(IABS(I),1)/3D0
              AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
              VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
            ELSE
              AI=-(1D0-2D0*XW)
              VI=-1D0+4D0*XW
            ENDIF
            HI=HP*(VI**2+AI**2)
            IF(IABS(I).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
  350     CONTINUE
 
        ELSEIF(ISUB.EQ.354) THEN
C...f + fbar' -> W_R+/-
          SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
          CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
          HP=AEM/(24D0*XW)*SH
          DO 370 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
            IA=IABS(I)
            DO 360 J=MMIN2,MMAX2
              IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
              JA=IABS(J)
              IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
              IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
     &        GOTO 360
              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
  360       CONTINUE
  370     CONTINUE
        ENDIF
 
      ELSEIF(ISUB.LE.400) THEN
        IF(ISUB.EQ.391) THEN
C...f + fbar -> G*.
          KFGSTR=KFPR(ISUB,1)
          KCGSTR=PYCOMP(KFGSTR)
          CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
     &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
C...Modify cross section in wings of peak.
          FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
          DO 380 I=MMINA,MMAXA
            IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
            HI=1D0
            IF(IABS(I).LE.10) HI=HI*FACA/3D0
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACG*HI
  380     CONTINUE
 
        ELSEIF(ISUB.EQ.392) THEN
C...g + g -> G*.
          KFGSTR=KFPR(ISUB,1)
          KCGSTR=PYCOMP(KFGSTR)
          CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
          HS=SHR*WDTP(0)
          HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
     &    ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
C...Modify cross section in wings of peak.
          FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
          IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
          NCHN=NCHN+1
          ISIG(NCHN,1)=21
          ISIG(NCHN,2)=21
          ISIG(NCHN,3)=1
          SIGH(NCHN)=FACG
  390     CONTINUE
 
        ELSEIF(ISUB.EQ.393) THEN
C...q + qbar -> g + G*.
          KFGSTR=KFPR(ISUB,2)
          KCGSTR=PYCOMP(KFGSTR)
          FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
     &    (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
     &    3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
     &    2D0*SH2/(TH*UH))
C...Propagators: as simulated in PYOFSH and as desired
          GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
          HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
          CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
          HS=SQRT(SQM4)*WDTP(0)
          HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
          FACG=FACG*HBW4C/HBW4
          DO 400 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
            NCHN=NCHN+1
            ISIG(NCHN,1)=I
            ISIG(NCHN,2)=-I
            ISIG(NCHN,3)=1
            SIGH(NCHN)=FACG
  400     CONTINUE
 
        ELSEIF(ISUB.EQ.394) THEN
C...q + g -> q + G*.
          KFGSTR=KFPR(ISUB,2)
          KCGSTR=PYCOMP(KFGSTR)
          FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
     &    (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
     &    3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
     &    2D0*TH2*TH/(UH*SH2))
C...Propagators: as simulated in PYOFSH and as desired
          GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
          HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
          CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
          HS=SQRT(SQM4)*WDTP(0)
          HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
          FACG=FACG*HBW4C/HBW4
          DO 420 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
            DO 410 ISDE=1,2
              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=FACG
  410       CONTINUE
  420     CONTINUE
 
        ELSEIF(ISUB.EQ.395) THEN
C...g + g -> g + G*.
          KFGSTR=KFPR(ISUB,2)
          KCGSTR=PYCOMP(KFGSTR)
          FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
     &    ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
     &    3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
C...Propagators: as simulated in PYOFSH and as desired
          GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
          HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
          CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
          HS=SQRT(SQM4)*WDTP(0)
          HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
          HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
          FACG=FACG*HBW4C/HBW4
          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)=FACG
          ENDIF
        ENDIF
      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/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/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)
      COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
     &     XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
     &     XMI(2,240),PT2MI(240),IMISEP(0:240)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
     &/PYINT9/,/PYINTM/
C...Local arrays.
      DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
     &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
      SAVE PPAR
 
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...Valence PDF momentum integral parametrizations PER PARTON!
      DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
      DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
      PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
     &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
 
C...Reset parton distributions.
      MINT(92)=0
      DO 100 KFL=-25,25
        XPQ(KFL)=0D0
  100 CONTINUE
      DO 110 KFL=-6,6
        XPVAL(KFL)=0D0
  110 CONTINUE
 
C...Check x and particle species.
      IF(X.LE.0D0.OR.X.GE.1D0) THEN
        WRITE(MSTU(11),5000) X
        GOTO 9999
      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.AND.KFA.NE.321.AND.
     &KFA.NE.310.AND.KFA.NE.130) THEN
        WRITE(MSTU(11),5100) KF
        GOTO 9999
      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 120 KFL=-25,25
          XPQ(KFL)=XPEL(KFL)
  120   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 130 KFL=-6,6
            XPQ(KFL)=XPGA(KFL)
  130     CONTINUE
          XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
          XPVAL(1)=XPVU/4D0
          XPVAL(2)=XPVU
          XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
          XPVAL(4)=MIN(XPQ(4),XPVU)
          XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
          XPVAL(-1)=XPVAL(1)
          XPVAL(-2)=XPVAL(2)
          XPVAL(-3)=XPVAL(3)
          XPVAL(-4)=XPVAL(4)
          XPVAL(-5)=XPVAL(5)
        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 140 KFL=-6,6
            XPQ(KFL)=XPGA(KFL)
            XPVAL(KFL)=VXPDGM(KFL)
  140     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 150 KFL=-6,6
            XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
            XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
  150     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
          XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
          XPVAL(1)=XPVU/4D0
          XPVAL(2)=XPVU
          XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
          XPVAL(4)=MIN(XPQ(4),XPVU)
          XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
          XPVAL(-1)=XPVAL(1)
          XPVAL(-2)=XPVAL(2)
          XPVAL(-3)=XPVAL(3)
          XPVAL(-4)=XPVAL(4)
          XPVAL(-5)=XPVAL(5)
        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.321.OR.KFA.EQ.130.OR.
     &KFA.EQ.310.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 160 KFL=-6,6
            XPQ(KFL)=XPVMD(KFL)
            XPVAL(KFL)=VXPVMD(KFL)
  160     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 170 KFL=-6,6
            XPQ(KFL)=XPPI(KFL)
  170     CONTINUE
          XPVAL(2)=XPQ(2)-XPQ(-2)
          XPVAL(-1)=XPQ(-1)-XPQ(1)
        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
          XPVAL(2)=UPV
          XPVAL(-1)=UPV
        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 180 KFL=-6,6
            XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
            XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
  180     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 190 KFL=-6,6
            XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
            XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
  190     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 200 KFL=-6,6
            XPQ(KFL)=XPGA(KFL)
            XPVAL(KFL)=VXPGA(KFL)
  200     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 210 KFL=-6,6
            XPQ(KFL)=XPGA(KFL)
            XPVAL(KFL)=VXPGA(KFL)
  210     CONTINUE
          VINT(231)=P2MX
        ELSE
  220     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 220
          IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
          IF(MSTP(57).EQ.0) Q2MX=P2MX
          CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
          DO 230 KFL=-6,6
            XPQ(KFL)=XPGA(KFL)
            XPVAL(KFL)=VXPGA(KFL)
  230     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 240 KFL=-6,6
            XPQ(KFL)=XPPR(KFL)
  240     CONTINUE
C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
          XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
          XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
        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
          XPVAL(1)=DNV
          XPVAL(2)=UPV
        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
        XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
     &  XPVAL(3)+XPVAL(4)+XPVAL(5)
        DO 250 KFL=-6,6
          XPVAL(KFL)=0D0
  250   CONTINUE
        IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
          XPQ(1)=XPQ(1)+0.2D0*XPV
          XPQ(2)=XPQ(2)+0.8D0*XPV
          XPVAL(1)=0.2D0*XPVL
          XPVAL(2)=0.8D0*XPVL
        ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
          XPQ(3)=XPQ(3)+XPV
          XPVAL(3)=XPVL
        ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
          XPQ(4)=XPQ(4)+XPV
          XPVAL(4)=XPVL
          IF(MSTP(55).GE.9) THEN
            DO 260 KFL=-6,6
              XPQ(KFL)=0D0
  260       CONTINUE
          ENDIF
        ELSE
          XPQ(1)=XPQ(1)+0.5D0*XPV
          XPQ(2)=XPQ(2)+0.5D0*XPV
          XPVAL(1)=0.5D0*XPVL
          XPVAL(2)=0.5D0*XPVL
        ENDIF
        DO 270 KFL=1,6
          XPQ(-KFL)=XPQ(KFL)
          XPVAL(-KFL)=XPVAL(KFL)
  270   CONTINUE
 
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 280 KFL=-6,6
            XPQ(KFL)=VINT(281)*XPQ(KFL)
            XPVAL(KFL)=VINT(281)*XPVAL(KFL)
  280     CONTINUE
          VINT(232)=VINT(281)*XPV
        ENDIF
 
C...Simple recipes for kaons.
      ELSEIF(KFA.EQ.321) THEN
        XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
        XPQ(-1)=XPQ(1)
        XPVAL(-3)=XPVAL(-1)
        XPVAL(-1)=0D0
      ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
        XPS=0.5D0*(XPQ(1)+XPQ(-2))
        XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
        XPQ(2)=XPS
        XPQ(-1)=XPS
        XPQ(1)=XPQ(1)+0.5D0*XPV
        XPQ(-1)=XPQ(-1)+0.5D0*XPV
        XPQ(3)=XPQ(3)+0.5D0*XPV
        XPQ(-3)=XPQ(-3)+0.5D0*XPV
        XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
        XPVAL(2)=0D0
        XPVAL(-1)=0D0
        XPVAL(1)=0.5D0*XPV
        XPVAL(-1)=0.5D0*XPV
        XPVAL(3)=0.5D0*XPV
        XPVAL(-3)=0.5D0*XPV
 
C...Isospin conjugation for neutron.
      ELSEIF(KFA.EQ.2112) THEN
        XPSV=XPQ(1)
        XPQ(1)=XPQ(2)
        XPQ(2)=XPSV
        XPSV=XPQ(-1)
        XPQ(-1)=XPQ(-2)
        XPQ(-2)=XPSV
        XPSV=XPVAL(1)
        XPVAL(1)=XPVAL(2)
        XPVAL(2)=XPSV
 
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
        XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
        XPS=0.5D0*(XPQ(-1)+XPQ(-2))
        XPQ(1)=XPS
        XPQ(2)=XPS
        XPQ(-1)=XPS
        XPQ(-2)=XPS
        XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
        XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
        XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
        XPV=(XPVAL(1)+XPVAL(2))/3D0
        XPVAL(1)=0D0
        XPVAL(2)=0D0
        XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
        XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
        XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
      ENDIF
 
C...Charge conjugation for antiparticle.
      IF(KF.LT.0) THEN
        DO 290 KFL=1,25
          IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
          XPSV=XPQ(KFL)
          XPQ(KFL)=XPQ(-KFL)
          XPQ(-KFL)=XPSV
  290   CONTINUE
        DO 300 KFL=1,6
          XPSV=XPVAL(KFL)
          XPVAL(KFL)=XPVAL(-KFL)
          XPVAL(-KFL)=XPSV
  300  CONTINUE
      ENDIF
 
C...MULTIPLE INTERACTIONS - PDF RESHAPING.
C...Set side.
      JS=MINT(30)
C...Only reshape PDFs for the non-first interactions;
C...But need valence/sea separation already from first interaction.
      IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
        KFVSEL=KFIVAL(JS,1)
C...If valence quark kicked out of pi0 or gamma then that decides
C...whether we should consider state as d dbar, u ubar, s sbar, etc.
        IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
          XPVL=0D0
          DO 310 KFL=1,6
            XPVL=XPVL+XPVAL(KFL)
            XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
            XPVAL(KFL)=0D0
  310     CONTINUE
          XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
          XPVAL(IABS(KFVSEL))=XPVL
          DO 320 KFL=1,6
            XPQ(-KFL)=XPQ(KFL)
            XPVAL(-KFL)=XPVAL(KFL)
  320     CONTINUE
 
C...If valence quark kicked out of K0S or K0S then that decides whether
C...we should consider state as d sbar or s dbar.
        ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
          KFS=1
          IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
          XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
          XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
          XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
          XPVAL(-KFS)=0D0
          KFS=-3*KFS
          XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
          XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
          XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
          XPVAL(-KFS)=0D0
        ENDIF
 
C...XPQ distributions are nominal for a (signed) beam particle
C...of KF type, with 1-Sum(x_prev) rescaled to 1.
        CMPFAC=1D0
        NRESC=0
 345    NRESC=NRESC+1
        PVCTOT(JS,-1)=0D0
        PVCTOT(JS, 0)=0D0
        PVCTOT(JS, 1)=0D0
        DO 350 IFL=-6,6
          IF(IFL.EQ.0) GOTO 350
 
C...Count up number of original IFL valence quarks.
          IVORG=0
          IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
          IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
          IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
C...bookkeep as if d dbar (for total momentum sum in valence sector).
          IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
C...Count down number of remaining IFL valence quarks. Skip current
C...interaction initiator.
          IVREM=IVORG
          DO 330 I1=1,NMI(JS)
            IF (I1.EQ.MINT(36)) GOTO 330
            IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
     &           IVREM=IVREM-1
  330     CONTINUE
 
C...Separate out original VALENCE and SEA content.
          VAL=XPVAL(IFL)
          SEA=MAX(0D0,XPQ(IFL)-VAL)
          XPSVC(IFL,0)=VAL
          XPSVC(IFL,-1)=SEA
 
C...Rescale valence content if changed.
          IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
     &    (VAL*IVREM)/IVORG
 
C...Momentum integrals of original and removed valence quarks.
          IF(IVORG.NE.0) THEN
C...For p/n/pbar/nbar beams can split into d_val and u_val.
C...Isospin conjugation for neutrons
            IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
              IAFLP=IABS(IFL)
              IF (KFA.EQ.2112) IAFLP=3-IAFLP
              VPAVG=PAVG(IAFLP,Q2)
C...For other baryons average d_val and u_val, like for PDFs.
            ELSEIF(KFA.GT.1000) THEN
              VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
C...For mesons and photon average d_val and u_val and scale by 3/2.
C...Very crude, especially for photon.
            ELSE
              VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
            ENDIF
            PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
            PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
          ENDIF
 
C...Now add companions (at X with partner having been at Z=XASSOC).
C...NOTE: due to the assumed simple x scaling, the partner was at what
C...corresponds to a higher Z than XASSOC, if there were intermediate
C...scatterings. Nothing done about that for the moment.
          DO 340 IVC=1,NVC(JS,IFL)
C...Skip companions that have been kicked out
            IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
              XPSVC(IFL,IVC)=0D0
              GOTO 340
            ELSE
C...Momentum fraction of the partner quark.
C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
              XS=XASSOC(JS,IFL,IVC)
              XREM=VINT(142+JS)
              YS=XS/(XREM+XS)
C...Momentum fraction of the companion quark.
C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
              Y=X*(1D0-YS)
              XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
C...Add to momentum sum, with rescaling compensation factor.
              XCFAC=(XREM+XS)/XREM*CMPFAC
              PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
            ENDIF
  340     CONTINUE
  350   CONTINUE
 
C...Wait until all flavours treated, then rescale seas and gluon.
        XPSVC(0,-1)=XPQ(0)
        XPSVC(0,0)=0D0
        RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
        IF (RSFAC.LE.0D0) THEN
C...First calculate factor needed to exactly restore pz cons.
          IF (NRESC.EQ.1) CMPFAC =
     &         (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
C...Add a bit of headroom
          CMPFAC=0.99*CMPFAC
C...Try a few times if more headroom is needed, then print error message.
          IF (NRESC.LE.10) GOTO 345
          CALL PYERRM(15,
     &         '(PYPDFU:) Negative reshaping factor persists!')
          WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
          RSFAC=0D0
        ENDIF
        DO 370 IFL=-6,6
          XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
C...Also store resulting distributions in XPQ
          XPQ(IFL)=0D0
          DO 360 ISVC=-1,NVC(JS,IFL)
            XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
  360     CONTINUE
  370   CONTINUE
C...Save companion reweighting factor for PYPTIS.
        VINT(140)=CMPFAC
      ENDIF
 
 
C...Allow gluon also in position 21.
      XPQ(21)=XPQ(0)
 
C...Check positivity and reset above maximum allowed flavour.
      DO 380 KFL=-25,25
        XPQ(KFL)=MAX(0D0,XPQ(KFL))
        IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
  380 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)
 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
     &       ' Removed valence momentum fraction  : ',F6.3/
     &       ' Added companion momentum fraction  : ',F6.3/
     &       ' Resulting rescale factor           : ',F6.3)
 
C...Reset side pointer and return
 9999 MINT(30)=0
 
      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.
      MINT30=MINT(30)
      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.
        MINT(30)=MINT30
        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.
        MINT(30)=MINT30
        CALL PYPDFU(KFC,XMN,Q2MN,XPA)
        VI232A=VINT(232)
        MINT(30)=MINT30
        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.
        MINT(30)=MINT30
        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
            IF(MSTP(55).EQ.1) THEN
              CALL PYPDGA(XG,Q2,XPGA)
            ELSEIF(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,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
              VINT(231)=P2MX
            ELSEIF(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,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
              VINT(231)=P2MX
            ENDIF
            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 Glueck, 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(1D8,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(1D8,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...PYCT5L
C...Auxiliary function for parametrization of CTEQ5L.
C...Author: J. Pumplin 9/99.
 
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 PDFs 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.
 
      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 Glueck, Reya and
C...Vogt. 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 120 KFL=1,6
          XQSUM=0D0
          DO 110 IT=1,6
            DO 100 IX=1,6
              XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
  100       CONTINUE
  110     CONTINUE
          XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
  120   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 140 IT=1,6
              DO 130 IX=1,6
                XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
  130         CONTINUE
  140       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 160 IT=1,6
              DO 150 IX=1,6
                XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
  150         CONTINUE
  160       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 180 KFL=1,5
          DO 170 IS=1,6
            TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
     &      CDO(3,IS,KFL,NSET)*SD**2
  170     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
  180   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
      ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
        KFL(2)=MOD(KFA/10,10)
        KFL(3)=MOD(KFA/100,10)
      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.110.OR.KFA.EQ.990) 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...Special case for extracting photon from baryon without splitting
C...the latter. (Currently only used by external programs.)
      ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
        KFLSP=KFA
        KFLCH=0
 
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=I,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/9D0
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYSTBH (and auxiliaries)
C.. Evaluates the matrix elements for t + b + H production.
 
      SUBROUTINE PYSTBH(WTTBH)
 
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)
      COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
      COMMON/PYINT4/MWID(500),WIDS(500,5)
      COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
      DOUBLE PRECISION MW2
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
     &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
 
C...LOCAL ARRAYS AND COMPLEX VARIABLES
      DIMENSION QQ(4,2),PP(4,3)
      DATA QQ/8*0D0/
 
      WTTBH=0D0
 
C...KINEMATIC PARAMETERS.
      SHPR=SQRT(VINT(26))*VINT(1)
      PH=SQRT(VINT(21))*VINT(1)
      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(1,I)=PT*COS(VINT(198+5*I))
        PP(2,I)=PT*SIN(VINT(198+5*I))
  100 CONTINUE
      PP(1,3)=-PP(1,1)-PP(1,2)
      PP(2,3)=-PP(2,1)-PP(2,2)
      PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
      PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
      PMS3=SPH+PP(1,3)**2+PP(2,3)**2
      PMT3=SQRT(PMS3)
      PP(3,3)=PMT3*SINH(VINT(211))
      PP(4,3)=PMT3*COSH(VINT(211))
      PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
      PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
     &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
      PP(3,2)=-PP(3,1)-PP(3,3)
      PP(4,1)=SQRT(PMS1+PP(3,1)**2)
      PP(4,2)=SQRT(PMS2+PP(3,2)**2)
 
C...CM SYSTEM, INGOING QUARKS/GLUONS
      QQ(3,1) = SHPR/2.D0
      QQ(4,1) = QQ(3,1)
      QQ(3,2) = -QQ(3,1)
      QQ(4,2) = QQ(4,1)
 
C...PARAMETERS FOR AMPLITUDE METHOD
      ALPHA = AEM
      ALPHAS = AS
      SW2 = PARU(102)
      MW2 = PMAS(24,1)**2
      TANB = PARU(141)
      VTB = VCKM(3,3)
      RMB=PYMRUN(5,VINT(52))
 
      ISUB=MINT(1)
 
      IF (ISUB.EQ.401) THEN
        CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
     &  VINT(201),VINT(206),RMB,VINT(43),WTTBH)
      ELSE IF (ISUB.EQ.402) THEN
        CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
     &  VINT(201),VINT(206),RMB,VINT(43),WTTBH)
      END IF
 
      RETURN
      END
C------------------------------------------------------------------
      SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
C  WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
      COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
      SAVE /PYCTBH/
 
C   TOP WIDTH CALCULATION
C       VTB  = 0.99
      MW=DSQRT(MW2)
      XB=(MB/MT)**2
      XW=(MW/MT)**2
      XH =(MHP/MT)**2
      GAMTBH = 0D0
      IF (MT .LT. (MHP+MB)) THEN
C  T ->B W ONLY
         BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
         GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
     &        (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
         GAMT  = GAMTBW
      ELSE
C T ->BW +T ->B H^+
         BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
         GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
     &        (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
C
         KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
     &        -4.D0*(MHP*MB/MT**2)**2 )
         GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
     &        (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
         GAMT  = GAMTBW+GAMTBH
      ENDIF
C THUS BR IS
      BR=GAMTBH/GAMT
      RETURN
      END
 
C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
C GG->TBH^+, QQBAR->TBH^+
C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
C (FOR INSTANCE WITH PYTHIA)
C------------------------------------------------------------
C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY  HEP-PH/9905443,
C PHYS REV. D 60 (1999) 115011
C (THESE FILES PREPARED BY J.-L. KNEUR)
C------------------------------------------------------------
C 1)  GG->TBH^+
       SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
C
C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
C
C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
C        P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
C        P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
C  (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
C "PHYSICAL PARAMETERS" INPUT:
C        MT,MB TOP AND BOTTOM MASSES;
C        MHP CHARGED HIGGS MASS
C   FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
C
C OUTPUT: AMP2  IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
C   SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
C           STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
C
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      DOUBLE PRECISION MW2,MT,MB,MHP,MW
      DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
      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/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
C (TAN BETA) VALUES
C
C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
 
      PI = 4*DATAN(1.D0)
      MW = DSQRT(MW2)
C
C COLLECTING THE RELEVANT OVERALL FACTORS:
C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
      PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
C COUPLING CONSTANT (OVERALL NORMALIZATION)
      FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
C ALPHAS IS ALPHA_STRONG;
C SW2 IS SIN(THETA_W)**2.
C
C      VTB=.998D0
C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
C
      V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
      A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
C
C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
      DO 100 KK=1,4
      P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
  100 CONTINUE
C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
      S = 2*PYTBHS(Q1,Q2)
      P1Q1=PYTBHS(Q1,P1)
      P1Q2=PYTBHS(P1,Q2)
      P2Q1=PYTBHS(P2,Q1)
      P2Q2=PYTBHS(P2,Q2)
      P1P2=PYTBHS(P1,P2)
C
C   TOP WIDTH CALCULATION
      CALL PYTBHB(MT,MB,MHP,BR,GAMT)
C   GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
C THEN DEFINE TOP (RESONANT) PROPAGATOR:
      A1INV= S -2*P1Q1 -2*P1Q2
      A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
C  NB:    A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
C  THE TOP WIDTH
      A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
      A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
C  NOW COMES THE AMP**2:
C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
C THE EXPRESSIONS BELOW
      V18=0.D0
      A18=0.D0
      V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
     &512*A1*A2*MB*MT/3-
     &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
     &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
     &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
     &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
     &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
     &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
     &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
     &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
     &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
     &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
     &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
     &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
     &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
     &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
     &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
      V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
     &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
     &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
     &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
     &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
     &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
     &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
     &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
     &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
     &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
     &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
     &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
     &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
     &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
     &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
     &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
     &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
      V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
     &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
     &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
     &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
     &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
     &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
     &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
     &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
     &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
     &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
     &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
     &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
     &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
      V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
     &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
     &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
     &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
     &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
     &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
     &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
     &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
     &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
     &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
     &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
     &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
     &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
     &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
     &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
     &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
     &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
      V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
     &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
     &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
     &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
     &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
     &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
     &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
     &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
     &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
     &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
     &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
     &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
     &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
     &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
      V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
     &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
     &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
     &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
     &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
     &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
     &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
     &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
     &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
     &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
     &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
     &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
     &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
     &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
      V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
     &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
     &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
     &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
     &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
     &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
     &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
     &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
     &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
     &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
     &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
     &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
     &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
     &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
     &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
     &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
     &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
      V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
     &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
     &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
     &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
     &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
     &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
     &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
     &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
     &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
     &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
     &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
     &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
     &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
     &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
     &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
     &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
     &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
      V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
     &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
     &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
     &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
     &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
     &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
     &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
     &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
     &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
     &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
     &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
     &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
     &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
     &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
     &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
     &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
      V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
     &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
     &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
     &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
     &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
     &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
     &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
     &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
     &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
     &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
     &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
     &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
     &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
     &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
     &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
      V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
     &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
     &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
     &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
     &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
     &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
     &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
     &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
     &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
     &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
     &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
     &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
      V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
     &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
     &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
     &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
     &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
     &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
     &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
     &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
     &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
     &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
     &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
     &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
     &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
     &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
     &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
      V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
     &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
     &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
     &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
     &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
     &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
     &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
     &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
     &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
     &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
     &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
     &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
      V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
     &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
     &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
     &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
     &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
     &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
     &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
     &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
     &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
     &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
     &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
     &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
     &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
     &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
     &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
     &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
      V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
     &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
     &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
     &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
     &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
     &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
     &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
     &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
     &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
     &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
     &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
     &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
     &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
     &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
     &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
      V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
     &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
     &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
     &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
     &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
     &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
     &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
     &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
     &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
     &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
     &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
      V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
     &384*A12*MB*MT*P1Q1**2/S**2+
     &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
     &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
     &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
     &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
     &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
     &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
     &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
     &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
     &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
     &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
     &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
     &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
     &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
     &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
     &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
     &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
      V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
     &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
     &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
     &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
     &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
     &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
     &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
     &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
     &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
     &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
     &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
     &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
     &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
     &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
     &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
     &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
     &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
      V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
     &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
     &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
     &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
     &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
     &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
     &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
     &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
     &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
     &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
     &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
     &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
     &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
     &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
     &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
     &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
     &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
     &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
      V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
     &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
     &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
     &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
     &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
     &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
     &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
     &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
     &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
     &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
     &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
     &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
     &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
     &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
     &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
     &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
     &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
      V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
     &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
     &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
     &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
     &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
     &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
     &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
     &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
     &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
     &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
     &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
     &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
     &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
     &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
     &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
     &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
     &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
     &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
      V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
     &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
     &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
     &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
     &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
     &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
     &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
     &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
     &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
     &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
     &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
     &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
     &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
     &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
     &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
     &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
     &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
      V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
     &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
     &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
     &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
     &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
     &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
     &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
     &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
     &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
     &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
     &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
     &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
     &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
     &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
     &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
     &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
      V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
     &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
     &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
     &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
     &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
     &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
     &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
     &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
     &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
     &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
     &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
     &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
     &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
     &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
      V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
     &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
     &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
     &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
     &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
     &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
     &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
     &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
     &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
     &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
     &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
     &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
     &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
     &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
     &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
     &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
     &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
      V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
     &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
     &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
     &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
     &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
     &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
     &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
     &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
     &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
     &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
     &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
     &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
     &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
     &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
     &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
     &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
     &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
      V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
     &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
     &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
 
      V18BIS=
     &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
     &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
     &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
     &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
     &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
     &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
     &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
     &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
     &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
     &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
     &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
     &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
      V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
     &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
     &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
     &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
     &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
     &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
     &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
     &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
     &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
     &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
     &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
     &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
     &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
     &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
      V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
     &272*A1*A2*P1Q1*S/(3*P1Q2)+
     &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
     &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
     &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
     &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
     &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
     &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
     &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
     &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
     &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
     &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
     &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
     &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
     &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
     &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
     &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
      V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
     &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
     &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
     &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
     &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
     &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
     &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
     &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
     &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
     &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
     &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
     &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
     &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
     &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
     &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
     &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
     &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
      V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
     &32*A12*P2Q1*S/(3*P1Q1)-
     &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
     &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
     &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
     &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
     &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
     &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
     &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
     &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
     &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
     &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
     &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
     &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
     &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
     &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
     &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
      V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
     &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
     &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
     &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
     &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
     &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
     &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
     &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
     &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
     &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
     &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
     &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
     &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
     &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
     &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
     &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
     &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
      V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
     &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
     &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
     &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
     &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
     &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
     &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
     &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
     &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
     &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
      V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
     &272*A1*A2*P2Q1*S/(3*P2Q2)-
     &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
     &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
     &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
     &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
     &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
     &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
     &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
     &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
     &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
     &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
     &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
     &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
     &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
     &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
     &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
      V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
     &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
     &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
     &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
     &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
     &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
     &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
     &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
C
 
      A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
     &512*A1*A2*MB*MT/3+
     &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
     &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
     &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
     &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
     &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
     &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
     &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
     &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
     &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
     &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
     &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
     &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
     &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
     &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
     &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
      A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
     &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
     &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
     &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
     &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
     &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
     &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
     &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
     &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
     &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
     &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
     &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
     &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
     &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
     &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
     &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
     &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
      A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
     &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
     &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
     &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
     &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
     &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
     &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
     &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
     &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
     &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
     &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
     &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
     &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
     &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
      A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
     &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
     &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
     &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
     &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
     &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
     &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
     &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
     &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
     &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
     &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
     &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
     &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
     &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
     &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
     &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
     &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
      A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
     &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
     &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
     &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
     &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
     &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
     &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
     &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
     &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
     &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
     &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
     &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
     &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
     &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
     &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
      A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
     &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
     &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
     &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
     &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
     &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
     &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
     &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
     &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
     &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
     &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
     &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
     &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
     &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
     &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
      A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
     &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
     &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
     &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
     &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
     &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
     &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
     &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
     &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
     &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
     &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
     &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
     &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
     &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
     &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
     &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
     &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
      A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
     &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
     &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
     &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
     &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
     &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
     &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
     &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
     &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
     &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
     &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
     &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
     &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
     &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
     &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
     &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
     &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
      A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
     &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
     &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
     &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
     &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
     &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
     &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
     &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
     &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
     &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
     &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
     &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
     &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
     &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
     &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
     &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
      A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
     &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
     &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
     &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
     &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
     &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
     &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
     &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
     &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
     &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
     &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
     &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
     &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
     &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
     &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
     &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
      A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
     &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
     &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
     &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
     &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
     &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
     &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
     &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
     &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
     &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
     &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
     &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
     &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
      A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
     &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
     &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
     &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
     &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
     &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
     &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
     &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
     &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
     &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
     &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
     &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
     &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
     &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
     &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
     &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
      A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
     &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
     &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
     &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
     &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
     &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
     &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
     &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
     &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
     &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
     &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
     &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
     &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
     &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
     &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
      A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
     &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
     &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
     &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
     &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
     &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
     &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
     &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
     &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
     &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
     &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
     &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
     &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
     &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
     &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
     &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
     &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
      A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
     &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
     &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
     &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
     &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
     &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
     &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
     &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
     &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
     &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
     &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
     &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
     &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
     &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
     &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
     &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
      A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
     &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
     &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
     &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
     &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
     &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
     &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
     &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
     &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
     &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
     &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
     &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
     &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
     &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
      A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
     &384*A12*MB*MT*P1Q1**2/S**2+
     &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
     &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
     &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
     &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
     &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
     &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
     &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
     &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
     &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
     &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
     &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
     &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
     &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
     &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
     &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
      A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
     &384*A2**2*MB*MT*P2Q2**2/S**2+
     &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
     &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
     &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
     &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
     &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
     &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
     &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
     &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
     &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
     &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
     &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
     &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
     &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
     &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
     &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
      A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
     &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
     &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
     &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
     &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
     &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
     &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
     &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
     &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
     &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
     &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
     &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
     &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
     &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
     &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
     &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
     &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
      A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
     &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
     &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
     &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
     &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
     &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
     &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
     &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
     &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
     &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
     &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
     &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
     &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
     &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
     &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
     &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
     &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
      A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
     &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
     &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
     &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
     &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
     &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
     &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
     &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
     &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
     &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
     &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
     &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
     &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
     &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
     &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
     &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
     &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
      A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
     &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
     &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
     &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
     &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
     &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
     &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
     &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
     &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
     &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
     &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
     &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
     &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
     &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
     &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
     &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
     &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
      A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
     &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
     &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
     &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
     &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
     &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
     &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
     &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
     &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
     &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
     &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
     &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
     &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
     &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
     &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
     &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
      A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
     &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
     &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
     &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
     &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
     &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
     &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
     &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
     &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
     &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
     &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
     &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
     &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
      A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
     &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
     &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
     &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
     &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
     &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
     &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
     &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
     &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
     &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
     &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
     &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
     &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
     &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
     &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
     &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
     &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
      A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
     &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
     &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
     &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
     &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
     &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
     &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
     &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
     &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
     &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
     &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
     &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
     &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
     &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
     &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
     &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
     &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
      A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
     &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
     &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
     &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
     &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
     &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
     &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
     &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
     &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
     &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
      A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
     &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
     &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
     &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
     &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
     &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
     &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
     &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
     &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
     &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
     &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
     &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
     &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
     &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
     &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
      A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
     &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
     &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
     &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
     &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
     &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
     &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
     &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
 
      A18BIS=
     &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
     &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
     &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
     &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
     &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
     &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
     &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
     &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
     &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
     &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
     &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
     &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
     &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
     &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
     &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
     &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
      A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
     &12*S/(P1Q2*P2Q1)+
     &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
     &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
     &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
     &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
     &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
     &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
     &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
     &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
     &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
     &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
     &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
     &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
     &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
     &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
     &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
      A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
     &32*MB**2*S/(3*P1Q1*P2Q2**2)+
     &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
     &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
     &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
     &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
     &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
     &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
     &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
     &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
     &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
     &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
     &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
     &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
     &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
     &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
     &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
      A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
     &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
     &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
     &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
     &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
     &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
     &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
     &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
     &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
     &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
     &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
     &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
     &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
     &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
     &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
     &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
     &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
      A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
     &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
     &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
     &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
     &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
     &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
     &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
     &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
     &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
     &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
     &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
     &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
      A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
     &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
     &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
     &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
     &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
     &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
     &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
     &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
     &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
     &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
     &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
     &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
     &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
     &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
     &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
     &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
     &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
      A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
     &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
     &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
C
      V18=V18+V18BIS
      A18=A18+A18BIS
      V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
     &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
     &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
     &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
     &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
     &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
     &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
     &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
     &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
     &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
     &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
     &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
     &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
     &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
     &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
     &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
     &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
      V910=V910+96*A1*A2*P1P2*P2Q1/S-
     &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
     &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
     &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
     &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
     &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
C
      A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
     &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
     &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
     &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
     &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
     &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
     &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
     &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
     &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
     &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
     &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
     &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
     &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
     &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
     &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
     &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
     &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
      A910=A910+96*A1*A2*P1P2*P2Q1/S-
     &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
     &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
     &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
     &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
     &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
C
C FINAL RESULT;
C
      AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
 
      END
C---------------------------------------------------------
C 2)  Q QBAR ->TBH^+
       SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
C
C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      DOUBLE PRECISION MW2,MT,MB,MHP,MW
      DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
      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/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
C
C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
C
      DIMENSION YY(2,2)
 
      PI = 4*DATAN(1.D0)
      MW = DSQRT(MW2)
 
C COLLECTING THE RELEVANT OVERALL FACTORS:
C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
      PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
C COUPLING CONSTANT (OVERALL NORMALIZATION)
      FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
C ALPHAS IS ALPHA_STRONG;
C SW2 IS SIN(THETA_W)**2.
C
C      VTB=.998D0
C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
C
      V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
      A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
C
C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
      DO 100 KK=1,4
        P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
  100 CONTINUE
C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
      S = 2*PYTBHS(Q1,Q2)
      P1Q1=PYTBHS(Q1,P1)
      P1Q2=PYTBHS(P1,Q2)
      P2Q1=PYTBHS(P2,Q1)
      P2Q2=PYTBHS(P2,Q2)
      P1P2=PYTBHS(P1,P2)
C
C   TOP WIDTH CALCULATION
      CALL PYTBHB(MT,MB,MHP,BR,GAMT)
C   GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
C THEN DEFINE TOP (RESONANT) PROPAGATOR:
      A1INV= S -2*P1Q1 -2*P1Q2
      A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
C  NB  A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
      A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
      A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
C  NOW COMES THE AMP**2:
C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
C THE EXPRESSIONS BELOW
      YY(1, 1) = -16*A**2*A2**2*MB*MT+
     &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
     &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
     &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
     &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
     &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
     &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
     &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
     &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
     &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
     &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
     &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
     &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
     &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
     &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
     &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
     &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
      YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
     &32*A2**2*MB**2*P1P2*V**2/S+
     &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
     &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
     &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
      YY(1, 1)=2*YY(1, 1)
 
      YY(1, 2) = -32*A**2*A1*A2*MB*MT+
     &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
     &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
     &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
     &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
     &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
     &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
     &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
     &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
     &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
     &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
     &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
     &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
     &64*A**2*A1*A2*MB*MT*P1P2/S+
     &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
     &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
     &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
      YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
     &64*A**2*A1*A2*P1Q1*P2Q1/S-
     &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
     &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
     &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
     &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
     &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
     &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
     &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
     &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
     &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
     &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
     &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
     &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
     &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
     &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
     &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
      YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
     &32*A1*A2*P1P2*P1Q1*V**2/S+
     &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
     &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
     &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
     &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
 
 
      YY(2, 2) =-16*A**2*A12*MB*MT+
     &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
     &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
     &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
     &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
     &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
     &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
     &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
     &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
     &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
     &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
     &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
     &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
     &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
     &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
     &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
     &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
      YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
     &32*A12*MT**2*P2Q2*V**2/S-
     &32*A12*P1Q2*P2Q2*V**2/S
      YY(2, 2)=2*YY(2, 2)
 
      RES=YY(1,1)+2*YY(1,2)+YY(2,2)
      AMP2=  FACT*PS*VTB**2*RES
 
      END
C=====================================================================
C     ************* FUNCTION SCALAR PRODUCTS *************************
      DOUBLE PRECISION FUNCTION PYTBHS(A,B)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      DIMENSION A(4),B(4)
      DUM=A(4)*B(4)
      DO 100 ID=1,3
         DUM=DUM-A(ID)*B(ID)
  100 CONTINUE
      PYTBHS=DUM
      RETURN
      END
 
C*********************************************************************
 
C...PYMSIN
C...Initializes supersymmetry: finds sparticle masses and
C...branching ratios and stores this information.
C...AUTHOR: STEPHEN MRENNA
C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
 
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYDAT4/CHAF(500,2)
      CHARACTER CHAF*16
      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/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
     &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYHTRI/HHH(7)
      COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
     &/PYMSSM/,/PYMSRV/,/PYSSMT/
 
C...Local variables.
      DOUBLE PRECISION ALFA,BETA
      DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
      INTEGER I,J,J1,I1,K1
      INTEGER KC,LKNT,IDLAM(400,3)
      DOUBLE PRECISION XLAM(0:400)
      DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
      DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
      DOUBLE PRECISION DELM,XMDIF
      DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
      DOUBLE PRECISION ARG,SGNMU,R
      INTEGER IMSSM
      INTEGER IRPRTY
      INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
      SAVE 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,
     &      6,     24,     45,     46,1000045, 9*0/
      DATA INIT/0/
 
C...Automatically read QNUMBERS, MASS, and DECAY tables      
      IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
        NQNUM=0
        CALL PYSLHA(0,0,IFAIL)
        CALL PYSLHA(5,0,IFAIL)
      ENDIF
      IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)

C...Do nothing further 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 100 I=1,36
          KF=KFSUSY(I)
          KC=PYCOMP(KF)
          MWIDSU(I)=MWID(KC)
          MDCYSU(I)=MDCY(KC,1)
  100   CONTINUE
      ENDIF
 
C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
      DO 110 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
  110 CONTINUE
 
C...First part of routine: set masses and couplings.
 
C...Reset mixing values in sfermion sector to pure left/right.
      DO 120 I=1,16
        SFMIX(I,1)=1D0
        SFMIX(I,4)=1D0
        SFMIX(I,2)=0D0
        SFMIX(I,3)=0D0
  120 CONTINUE
 
C...Add NMSSM states if NMSSM switched on, and change old names.
      IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
C...  Switch on NMSSM
        WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
 
        KFN=25
        KCN=KFN
        CHAF(KCN,1)='h_10'
        CHAF(KCN,2)=' '
 
        KFN=35
        KCN=KFN
        CHAF(KCN,1)='h_20'
        CHAF(KCN,2)=' '
 
        KFN=45
        KCN=KFN
        CHAF(KCN,1)='h_30'
        CHAF(KCN,2)=' '
 
        KFN=36
        KCN=KFN
        CHAF(KCN,1)='A_10'
        CHAF(KCN,2)=' '
 
        KFN=46
        KCN=KFN
        CHAF(KCN,1)='A_20'
        CHAF(KCN,2)=' '
 
        KFN=1000045
        KCN=PYCOMP(KFN)
        IF (KCN.EQ.0) THEN
          DO 123 KCT=100,MSTU(6)
            IF(KCHG(KCT,4).GT.100) KCN=KCT
 123      CONTINUE
          KCN=KCN+1
          KCHG(KCN,4)=KFN
          MSTU(20)=0
        ENDIF
C...  Set stable for now
        PMAS(KCN,2)=1D-6
        MWID(KCN)=0
        MDCY(KCN,1)=0
        MDCY(KCN,2)=0
        MDCY(KCN,3)=0
        CHAF(KCN,1)='~chi_50'
        CHAF(KCN,2)=' '
      ENDIF
 
C...Read spectrum from SLHA file.
      IF (IMSSM.EQ.11) THEN
        CALL PYSLHA(1,0,IFAIL)
      ENDIF
 
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 130 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)
  130   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 140 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
  140   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
        RMSS(36)=RMSS(16)
        CALL PYAPPS
C...Or use ISASUSY
      ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
        RMSS(36)=RMSS(16)
        CALL PYSUGI
        ALFA=RMSS(18)
        GOTO 170
      ELSE
        GOTO 170
      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 150 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)
  150   CONTINUE
        DO 160 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)
  160   CONTINUE
        IF(RMSS(4)**2+DMU2.LT.0D0) THEN
          WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
          CALL PYSTOP(104)
        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 '
          CALL PYSTOP(104)
        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
 
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),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
     &  UMIXI(2,1),UMIXI(2,2)
        WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
     &  VMIX(2,1),VMIX(2,2)
        WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
     &  VMIXI(2,1),VMIXI(2,2)
        WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
        WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
        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.
  170 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)
      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
      IF(IMSS(4).GE.2) THEN
        PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
      ELSE
        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))
      ENDIF
C...Coupling to H+
C...Define later
      IF(IMSS(4).GE.2) THEN
        PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
      ELSE
        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)
      ENDIF
C...Coupling to A
      IF(IMSS(4).GE.2) THEN
        PARU(177)=COS(2D0*BE)*COS(BE+AL)
      ELSE
        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))
      ENDIF
C...Coupling to H+
      IF(IMSS(4).GE.2) THEN
        PARU(178)=PARU(177)
      ELSE
        PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
      ENDIF
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...Set R-Violating couplings.
C...Set lambda couplings to common value or "natural values".
      IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
        VIR3=1D0/(126D0)**3
        DO 200 IRK=1,3
          DO 190 IRI=1,3
            DO 180 IRJ=1,3
              IF (IRI.NE.IRJ) THEN
                IF (IRI.LT.IRJ) THEN
                  RVLAM(IRI,IRJ,IRK)=RMSS(51)
                  IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
     &              SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
     &              PMAS(9+2*IRK,1)*VIR3)
                ELSE
                  RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
                ENDIF
              ELSE
                RVLAM(IRI,IRJ,IRK)=0D0
              ENDIF
  180       CONTINUE
  190     CONTINUE
  200   CONTINUE
      ENDIF
C...Set lambda' couplings to common value or "natural values".
      IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
        VIR3=1D0/(126D0)**3
        DO 230 IRI=1,3
          DO 220 IRJ=1,3
            DO 210 IRK=1,3
              RVLAMP(IRI,IRJ,IRK)=RMSS(52)
              IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
     &          SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
     &          PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
  210       CONTINUE
  220     CONTINUE
  230   CONTINUE
      ENDIF
C...Set lambda'' couplings to common value or "natural values".
      IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
        VIR3=1D0/(126D0)**3
        DO 260 IRI=1,3
          DO 250 IRJ=1,3
            DO 240 IRK=1,3
              IF (IRJ.NE.IRK) THEN
                IF (IRJ.LT.IRK) THEN
                  RVLAMB(IRI,IRJ,IRK)=RMSS(53)
                  IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
     &              RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
     &              PMAS(2*IRK-1,1)*VIR3)
                ELSE
                  RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
                ENDIF
              ELSE
                RVLAMB(IRI,IRJ,IRK) = 0D0
              ENDIF
  240       CONTINUE
  250     CONTINUE
  260   CONTINUE
      ENDIF
 
C...Antisymmetrize couplings set by user
      IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
        DO 290 IRI=1,3
          DO 280 IRJ=1,3
            DO 270 IRK=1,3
              IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
                RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
                IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
              ENDIF
              IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
                RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
                IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
              ENDIF
  270       CONTINUE
  280     CONTINUE
  290   CONTINUE
      ENDIF
 
C...Write spectrum to SLHA file
      IF (IMSS(23).NE.0) THEN
        IFAIL=0
        CALL PYSLHA(3,0,IFAIL)
      ENDIF
 
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)/1D9
        PMAS(KC,2)=0D0
        IRPRTY=0
        WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
      ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
        IRPRTY=0
        IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
     &       ' ALLOWING SUSY LLE DECAYS'
        IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
     &       ' ALLOWING SUSY LQD DECAYS'
        IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
     &       ' ALLOWING SUSY UDD DECAYS'
        IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
     &   ' --- Warning: R-Violating couplings possibly',
     &       ' incompatible with proton decay'
      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 300 I=1,36
        KF=KFSUSY(I)
        IF(KF.EQ.1000039) GOTO 300
        KC=PYCOMP(KF)
        IF(PMAS(KC,1).LT.PMLSP) THEN
          ILSP=I
          PMLSP=PMAS(KC,1)
        ENDIF
  300 CONTINUE
      DO 370 I=1,50
        IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
        KF=KFSUSY(I)
        IF (KF.EQ.0) GOTO 370
        KC=PYCOMP(KF)
        LKNT=0
 
C...Check if there are any decays listed for this sparticle
C...in a file
        IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
          IFAIL=0
          CALL PYSLHA(2,KF,IFAIL)
          IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
        ELSEIF (I.GE.37) THEN
          GOTO 370
        ENDIF
 
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.AND.IRPRTY.EQ.1) 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 310 I1=0,100
            XLAM(I1)=0D0
  310     CONTINUE
          DO 330 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 330
            XLAM(I1)=WDTP(I1)
            XLAM(0)=XLAM(0)+XLAM(I1)
            DO 320 J1=1,3
              IDLAM(I1,J1)=KFDP(K1,J1)
  320       CONTINUE
            LKNT=LKNT+1
  330     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 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
          BRAT(IDC)=0D0
  340   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 360 IL=1,LKNT
            IDCSV=IDC
  350       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 360
            ELSEIF(IDC.EQ.IDCSV) THEN
              WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
     &        'channel not recognized:'
              WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
              GOTO 360
            ELSE
              GOTO 350
            ENDIF
  360     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
C...Write decays to SLHA file
          IF (IMSS(24).NE.0) THEN
            IFAIL=0
            CALL PYSLHA(4,KF,IFAIL)
          ENDIF
 
        ENDIF
  370 CONTINUE
 
      RETURN
      END
C*********************************************************************
 
C...PYSLHA
C...Read/write spectrum or decay data from SLHA standard file(s).
C...P. Skands
 
C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
C...          (KFORIG=0 : read all decay tables)
C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
C...          (KFORIG=0 : read all MASS entries)
 
      SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
 
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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYDAT4/CHAF(500,2)
      CHARACTER CHAF*16
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      CHARACTER*40 ISAVER,VISAJE
      COMMON/PYINT4/MWID(500),WIDS(500,5)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
C...SUSY blocks
      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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
      SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
 
C...Local arrays, character variables and data.
      COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
     &     AU(3,3),AD(3,3),AE(3,3)
      COMMON/PYLH3C/CPRO(2),CVER(2)
C...The common block of new states (QNUMBERS / PARTICLE)
      COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
C...- NQNUM : Number of QNUMBERS blocks that have been read in
C...- KQNUM(I,0) : KF of new state
C...- KQNUM(I,1) : 3 times electric charge
C...- KQNUM(I,2) : Number of spin states: (2S + 1)
C...- KQNUM(I,3) : Colour rep  (1: singlet, 3: triplet, 8: octet)
C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
C...- KQNUM(I,5:9) : space available for further quantum numbers
      DIMENSION MMOD(100),MSPC(100),KFDEC(100)
      SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
C...MMOD: flags to set for each block read in.
C... 1: MODSEL     2: MINPAR     3: EXTPAR     4: SMINPUTS
C...MSPC: Flags to set for each block read in.
C... 1: MASS       2: NMIX       3: UMIX       4: VMIX       5: SBOTMIX
C... 6: STOPMIX    7: STAUMIX    8: HMIX       9: GAUGE     10: AU
C...11: AD        12: AE        13: YU        14: YD        15: YE
C...16: SPINFO    17: ALPHA     18: MSOFT     19: QNUMBERS
      CHARACTER CPRO*12,CVER*12,CHNLIN*6
      CHARACTER DOC*11, CHDUM*120, CHBLCK*60
      CHARACTER CHINL*120,CHKF*9,CHTMP*16
      INTEGER VERBOS
      SAVE VERBOS
C...Date of last Change
      PARAMETER (DOC='23 Jan 2009')
C...Local arrays and initial values
      DIMENSION IDC(5),KFSUSY(50)
      SAVE KFSUSY
      DATA NQNUM /0/
      DATA NDECAY /0/
      DATA VERBOS /1/
      DATA NHELLO /0/
      DATA MLHEF /0/
      DATA MLHEFD /0/
      DATA KFSUSY/
     &1000001,1000002,1000003,1000004,1000005,1000006,
     &2000001,2000002,2000003,2000004,2000005,2000006,
     &1000011,1000012,1000013,1000014,1000015,1000016,
     &2000011,2000012,2000013,2000014,2000015,2000016,
     &1000021,1000022,1000023,1000025,1000035,1000024,
     &1000037,1000039,     25,     35,     36,     37,
     &      6,     24,     45,     46,1000045, 9*0/
      DATA KFDEC/100*0/
      RMFUN(IP)=PMAS(PYCOMP(IP),1)
      
C...Shorthand for spectrum and decay table unit numbers
      IMSS21=IMSS(21)
      IMSS22=IMSS(22)
 
C...Default for LHEF input: read header information
      IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
      IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
      IF (IMSS21.EQ.MSTP(161)) MLHEF=1
      IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
 
C...Hello World
      IF (NHELLO.EQ.0) THEN
        IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
          WRITE(MSTU(11),5000) DOC
          NHELLO=1
        ENDIF
      ENDIF
 
C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
C...+MUPDA).
      LFN=IMSS21
      IF (MUPDA.EQ.2) LFN=IMSS22
      IF (MUPDA.EQ.3) LFN=IMSS(23)
      IF (MUPDA.EQ.4) LFN=IMSS(24)
C...Flag that we have not yet found whatever we were asked to find.
      IRETRN=1
 
C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
      IF (LFN.EQ.0) THEN
        WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
        GOTO 9999
      ENDIF
 
C...If reading LHEF header, start by rewinding file
      IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
 
C...If told to read spectrum, first zero all previous information.
      IF (MUPDA.EQ.1) THEN
C...Zero all block read flags
        DO 100 M=1,100
          MMOD(M)=0
          MSPC(M)=0
  100   CONTINUE
C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
        DO 110 ISUSY=1,36
          KC=PYCOMP(KFSUSY(ISUSY))
          PMAS(KC,1)=0D0
  110   CONTINUE
C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
        DO 130 J=1,4
          SFMIX(5,J) =0D0
          SFMIX(6,J) =0D0
          SFMIX(15,J)=0D0
          DO 120 L=1,4
            ZMIX(L,J) =0D0
            ZMIXI(L,J)=0D0
            IF (J.LE.2.AND.L.LE.2) THEN
              UMIX(L,J) =0D0
              UMIXI(L,J)=0D0
              VMIX(L,J) =0D0
              VMIXI(L,J)=0D0
            ENDIF
  120     CONTINUE
C...Zero signed masses.
          SMZ(J)=0D0
          IF (J.LE.2) SMW(J)=0D0
  130   CONTINUE
 
C...If reading decays, reset PYTHIA decay counters.
      ELSEIF (MUPDA.EQ.2) THEN
C...Check if DECAY for this KF already read
        IF (KFORIG.NE.0) THEN
          DO 140 IDEC=1,NDECAY
            IF (KFORIG.EQ.KFDEC(IDEC)) THEN
              IRETRN=0
              RETURN
            ENDIF
  140     CONTINUE
        ENDIF
        KCC=100
        NDC=0
        BRSUM=0D0
        DO 150 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)
  150   CONTINUE
      ELSEIF (MUPDA.EQ.5) THEN
C...Zero block read flags
        DO 160 M=1,100
          MSPC(M)=0
  160   CONTINUE
      ENDIF
 
C............READ
C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
      IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
C...Initialize program and version strings
        IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
        CPRO(MUPDA)=' '
        CVER(MUPDA)=' '
        ENDIF
 
C...Initialize read loop
        MERR=0
        NLINE=0
        CHBLCK=' '
C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
  170   CHINL=' '
        READ(LFN,'(A120)',END=400) CHINL
C...Count which line number we're at.
        NLINE=NLINE+1
        WRITE(CHNLIN,'(I6)') NLINE
 
C...Skip comment and empty lines without processing.
        IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
 
C...We assume all upper case below. Rewrite CHINL to all upper case.
        INL=0
        IGOOD=0
  180   INL=INL+1
        IF (CHINL(INL:INL).NE.'#') THEN
          DO 190 ICH=97,122
            IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
  190     CONTINUE
C...Extra safety. Chek for sensible input on line
          IF (IGOOD.EQ.0) THEN
            DO 200 ICH=48,90
              IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
  200       CONTINUE
          ENDIF
          IF (INL.LT.120) GOTO 180
        ENDIF
        IF (IGOOD.EQ.0) GOTO 170
 
C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
        DO 210 I1=1,10          
          IF (CHINL(I1:I1+5).EQ.'</SLHA'
     &        .OR.CHINL(I1:I1+5).EQ.'<EVENT' 
     &        .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
            REWIND(LFN)
            GOTO 400
          ENDIF
  210   CONTINUE
 
C...Check for BLOCK begin statement (spectrum).
        IF (CHINL(1:5).EQ.'BLOCK') THEN
          MERR=0
          READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
C...Check if another of this type of block was already read.
C...(logarithmic interpolation not yet implemented, so duplicates always
C...give errors)
          IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
          IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
          IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
          IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
          IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
          IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
          IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
          IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
          IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
          IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
          IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
          IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
          IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
          IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
          IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
          IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
          IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
C...Check for new particles
          IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
     &        THEN
            MSPC(19)=MSPC(19)+1
C...Read PDG code
            READ(CHBLCK(9:60),*) KFQ
 
            DO 220 MQ=1,NQNUM
              IF (KQNUM(MQ,0).EQ.KFQ) THEN
                MERR=17
                GOTO 380
              ENDIF
  220       CONTINUE
            IF (NHELLO.EQ.0) THEN
              WRITE(MSTU(11),5000) DOC
              NHELLO=1
            ENDIF
            WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &           ' * (PYSLHA:) Reading  '//CHBLCK(1:8)//
     &           '    for KF =',KFQ
            NQNUM=NQNUM+1
            KQNUM(NQNUM,0)=KFQ
            MSPC(19)=MSPC(19)+1
            KCQ=PYCOMP(KFQ)
C...Only read in new codes (also OK to overwrite if KF > 3000000)
            IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
              IF (KCQ.EQ.0) THEN
                DO 230 KCT=100,MSTU(6)
                  IF(KCHG(KCT,4).GT.100) KCQ=KCT
  230           CONTINUE
                KCQ=KCQ+1
              ENDIF
              KCC=KCQ
              KCHG(KCQ,4)=KFQ
C...First write PDG code as name
              WRITE(CHTMP,*) KFQ
              WRITE(CHTMP,'(A)') CHTMP(2:10)
C...Then look for real name
              IBEG=9
  240         IBEG=IBEG+1
              IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
  250         IBEG=IBEG+1
              IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
              IEND=IBEG-1
  260         IEND=IEND+1
              IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
              IF (IEND.LT.59) THEN
                READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
                IF (CHDUM.NE.' ') CHTMP=CHDUM
              ENDIF
  270         READ(CHTMP,'(A)') CHAF(KCQ,1)
              MSTU(20)=0
C...Set stable for now
              PMAS(KCQ,2)=1D-6
              MWID(KCQ)=0
              MDCY(KCQ,1)=0
              MDCY(KCQ,2)=0
              MDCY(KCQ,3)=0
            ELSE
              WRITE(MSTU(11),*)
     &           '* (PYSLHA:) KF =',KFQ,' already exists: ',
     &             CHAF(KCQ,1), '. Entry ignored.'
              MERR=7
            ENDIF
          ENDIF
C...Finalize this line and read next.
          GOTO 380
C...Check for DECAY begin statement (decays).
        ELSEIF (CHINL(1:3).EQ.'DEC') THEN
          MERR=0
          BRSUM=0D0
          CHBLCK='DECAY'
C...Read KF code and WIDTH
          MPSIGN=1
          READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
          IF (KF.LE.0) THEN
            KF=-KF
            MPSIGN=-1
          ENDIF
C...If this is not the KF we're looking for...
          IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
C...Set block skip flag and read next line.
            MERR=16
            GOTO 380
          ELSE
C...Check whether decay table for this particle already read in
            DO 280 IDECAY=1,NDECAY
              IF (KFDEC(IDECAY).EQ.KF) THEN
                WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
     &               ' * (PYSLHA:) Ignoring DECAY table ',
     &               'for KF =',KF,' on line ',CHNLIN,
     &               ' (duplicate)'
                MERR=16
                GOTO 380
              ENDIF
  280       CONTINUE
          ENDIF
 
C...Determine PYTHIA KC code of particle
          KCREP=0
          IF(KF.LE.100) THEN
            KCREP=KF
          ELSE
            DO 290 KCR=101,KCC
              IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
  290       CONTINUE
          ENDIF
          KC=KCREP
          IF (KCREP.NE.0) THEN
C...Particle is already known. Do not overwrite low-mass SM particles, 
C...since this could give problems at hadronization / hadron decay stage.
            IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
C...Set block skip flag and read next line
              WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &             ' * (PYSLHA:) Ignoring DECAY table for KF =',
     &             KF, ' (SLHA read-in not allowed)'
              MERR=16
              GOTO 380
            ENDIF
          ELSE
C...  Add new particle. Actually, this should not happen.
C...  New particles should be added already when reading the spectrum
C...  information, so go under previously stable category.
            KCC=KCC+1
            KC=KCC
          ENDIF
 
          IF (WIDTH.LE.0D0) THEN
C...Stable (i.e. LSP)
            WRITE(MSTU(11),'(A,I9,A,A)')
     &           '* (PYSLHA:) Reading  SLHA stable particle KF =',
     &              KF,', ',CHAF(KCREP,1)(1:16)
            IF (WIDTH.LT.0D0) THEN
              CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
     &             ' zero !')
              WIDTH=0D0
            ENDIF
            PMAS(KC,2)=1D-6
            MWID(KC)=0
            MDCY(KC,1)=0
C...Ignore any decay lines that may be present for this KF
            MERR=16
            MDCY(KC,2)=0
            MDCY(KC,3)=0
C...Return ok
            IRETRN=0
          ENDIF
C...Finalize and start reading in decay modes.
          GOTO 380
        ELSEIF (MOD(MERR,10).GE.6) THEN
C...If ignore block flag set, skip directly to next line.
          GOTO 170
        ENDIF
 
C...READ SPECTRUM
        IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
          IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
     &        THEN
            READ(CHINL,*) INDX, IVAL
            IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
            IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
            IF (INDX.EQ.3) KCHG(KCQ,2)=0
            IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
            IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
            IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
            IF (INDX.EQ.4) THEN
              KCHG(KCQ,3)=IVAL
              IF (IVAL.EQ.1) THEN
                CHTMP=CHAF(KCQ,1)
                IF (CHTMP.EQ.' ') THEN
                  WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
                  WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
                ELSE
                  ILAST=17
  300             ILAST=ILAST-1
                  IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
                  IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
                    CHTMP(ILAST:ILAST)='-'
                  ELSE
                    CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
                  ENDIF
                  CHAF(KCQ,2)=CHTMP
                ENDIF
              ENDIF
            ENDIF
          ELSE
            MERR=8
          ENDIF
        ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
C...MASS: Mass spectrum
          IF (CHBLCK(1:4).EQ.'MASS') THEN
            READ(CHINL,*) KF, VAL
            MERR=1
            KC=0
            IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
C...Read in masses for almost anything
              MERR=0
              KC=PYCOMP(KF)
              IF (KC.NE.0) THEN
C...Don't read in masses for special code particles
                IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
                  WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &                 ' * (PYSLHA:) Ignoring MASS  entry for KF =',
     &                 KF, ' (KF reserved by PYTHIA)' 
                  GOTO 170
                ENDIF
C...Be careful with light SM particles / hadrons
                IF (PMAS(KC,1).LE.20D0) THEN
                  IF (IABS(KF).LE.22) THEN
                    WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &                   ' * (PYSLHA:) Ignoring MASS  entry for KF =',
     &                   KF, ' (SLHA read-in not allowed)'

                    GOTO 170
                  ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
                    WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &                   ' * (PYSLHA:) Ignoring MASS  entry for KF =',
     &                   KF, ' (SLHA read-in not allowed)'
                    GOTO 170
                  ENDIF
                ENDIF
                MSPC(1)=MSPC(1)+1
                PMAS(KC,1) = ABS(VAL)
                IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
                  WRITE(MSTU(11),'(A,I9,A,F12.3)')
     &                 ' * (PYSLHA:) Reading  MASS  entry for KF =',
     &                 KF, ', pole mass =', VAL
                  IRETRN=0
                ENDIF
C...Check Z, W and top masses
                IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
     &               THEN
                  WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
                  CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
     &                 //CHTMP)
                ENDIF
                IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
     &               THEN
                  WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
                  CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
     &                 //CHTMP)
                ENDIF
                IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
     &               THEN
                  WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
                  CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
     &                 //CHTMP//'GeV')
                ENDIF
C...  Signed masses
                IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
                IF (KF.EQ.1000022) SMZ(1)=VAL
                IF (KF.EQ.1000023) SMZ(2)=VAL
                IF (KF.EQ.1000025) SMZ(3)=VAL
                IF (KF.EQ.1000035) SMZ(4)=VAL
                IF (KF.EQ.1000024) SMW(1)=VAL
                IF (KF.EQ.1000037) SMW(2)=VAL
              ENDIF
            ELSEIF (MUPDA.EQ.5) THEN
              MERR=0
            ENDIF
C...  MODSEL: Model selection and global switches
          ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
            READ(CHINL,*) INDX, IVAL
            IF (INDX.LE.200.AND.INDX.GT.0) THEN
              IF (IMSS(1).EQ.0) IMSS(1)=11
              MODSEL(INDX)=IVAL
              MMOD(1)=MMOD(1)+1
              IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
C...  Switch on NMSSM
                WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
                IMSS(13)=MAX(1,IMSS(13))
C...  Add NMSSM states if not already done
 
                KFN=25
                KCN=KFN
                CHAF(KCN,1)='h_10'
                CHAF(KCN,2)=' '
 
                KFN=35
                KCN=KFN
                CHAF(KCN,1)='h_20'
                CHAF(KCN,2)=' '
 
                KFN=45
                KCN=KFN
                CHAF(KCN,1)='h_30'
                CHAF(KCN,2)=' '
 
                KFN=36
                KCN=KFN
                CHAF(KCN,1)='A_10'
                CHAF(KCN,2)=' '
 
                KFN=46
                KCN=KFN
                CHAF(KCN,1)='A_20'
                CHAF(KCN,2)=' '
 
                KFN=1000045
                KCN=PYCOMP(KFN)
                IF (KCN.EQ.0) THEN
                  DO 310 KCT=100,MSTU(6)
                    IF(KCHG(KCT,4).GT.100) KCN=KCT
  310             CONTINUE
                  KCN=KCN+1
                  KCHG(KCN,4)=KFN
                  MSTU(20)=0
                ENDIF
C...  Set stable for now
                PMAS(KCN,2)=1D-6
                MWID(KCN)=0
                MDCY(KCN,1)=0
                MDCY(KCN,2)=0
                MDCY(KCN,3)=0
                CHAF(KCN,1)='~chi_50'
                CHAF(KCN,2)=' '
              ENDIF
            ELSE
              MERR=1
            ENDIF
          ELSEIF (MUPDA.EQ.5) THEN
C...If MUPDA = 5, skip all except MASS, return if MODSEL
            MERR=8
          ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
     &          CHBLCK(1:8).EQ.'PARTICLE') THEN
C...Don't print a warning for QNUMBERS when reading spectrum
            MERR=8
C...MINPAR: Minimal model parameters
          ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
            READ(CHINL,*) INDX, VAL
            IF (INDX.LE.100.AND.INDX.GT.0) THEN
              PARMIN(INDX)=VAL
              MMOD(2)=MMOD(2)+1
            ELSE
              MERR=1
            ENDIF
            IF (MMOD(3).NE.0) THEN
              WRITE(MSTU(11),*)
     &             '* (PYSLHA:) MINPAR should come before EXTPAR !'
              MERR=1
            ENDIF
C...tan(beta)
            IF (INDX.EQ.3) RMSS(5)=VAL
C...EXTPAR: non-minimal model parameters.
          ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
            IF (MMOD(1).NE.0) THEN
              READ(CHINL,*) INDX, VAL
              IF (INDX.LE.200.AND.INDX.GT.0) THEN
                PAREXT(INDX)=VAL
                MMOD(3)=MMOD(3)+1
              ELSE
                MERR=1
              ENDIF
            ELSE
              WRITE(MSTU(11),*)
     &             '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
              MERR=1
            ENDIF
C...tan(beta)
            IF (INDX.EQ.25) RMSS(5)=VAL
          ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
            READ(CHINL,*) INDX, VAL
            IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
              MERR=1
            ELSEIF (INDX.EQ.4) THEN
              PMAS(PYCOMP(23),1)=VAL
            ELSEIF (INDX.EQ.6) THEN
              PMAS(PYCOMP(6),1)=VAL
            ENDIF
          ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
     $           .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
     $           .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
     $           THEN
C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
            IM=0
            IF (CHBLCK(5:6).EQ.'IM') IM=1
  320       READ(CHINL,*) INDX1, INDX2, VAL
            IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
              IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
              IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
              MSPC(2)=MSPC(2)+1
            ELSEIF (CHBLCK(1:1).EQ.'U') THEN
              IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
              IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
              MSPC(3)=MSPC(3)+1
            ELSEIF (CHBLCK(1:1).EQ.'V') THEN
              IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
              IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
              MSPC(4)=MSPC(4)+1
            ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
     $             .CHBLCK(1:4).EQ.'STAU') THEN
              IF (CHBLCK(1:4).EQ.'STOP') THEN
                KFSM=6
                ISPC=6
              ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
                KFSM=5
                ISPC=5
              ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
                KFSM=15
                ISPC=7
              ENDIF
C...Set SFMIX element
              SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
              MSPC(ISPC)=MSPC(ISPC)+1
            ENDIF
C...Running parameters
          ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
            READ(CHBLCK(8:25),*,ERR=620) Q
            READ(CHINL,*) INDX, VAL
            MSPC(8)=MSPC(8)+1
            IF (INDX.EQ.1) THEN
              RMSS(4) = VAL
            ELSE
              MERR=1
              MSPC(8)=MSPC(8)-1
            ENDIF
          ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
            READ(CHINL,*,ERR=630) VAL
            RMSS(18)= VAL
            MSPC(17)=MSPC(17)+1
C...Higgs parameters set manually or with FeynHiggs.
            IMSS(4)=MAX(2,IMSS(4))
          ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
     &           .CHBLCK(1:2).EQ.'AE') THEN
            READ(CHBLCK(9:26),*,ERR=620) Q
            READ(CHINL,*) INDX1, INDX2, VAL
            IF (CHBLCK(2:2).EQ.'U') THEN
              AU(INDX1,INDX2)=VAL
              IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
              MSPC(11)=MSPC(11)+1
            ELSEIF (CHBLCK(2:2).EQ.'D') THEN
              AD(INDX1,INDX2)=VAL
              IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
              MSPC(10)=MSPC(10)+1
            ELSEIF (CHBLCK(2:2).EQ.'E') THEN
              AE(INDX1,INDX2)=VAL
              IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
              MSPC(12)=MSPC(12)+1
            ELSE
              MERR=1
            ENDIF
          ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
            IF (MSPC(18).EQ.0) THEN
              READ(CHBLCK(9:25),*,ERR=620) Q
              RMSOFT(0)=Q
            ENDIF
            READ(CHINL,*) INDX, VAL
            RMSOFT(INDX)=VAL
            MSPC(18)=MSPC(18)+1
          ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
            MERR=8
          ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
     &           .CHBLCK(1:2).EQ.'YE') THEN
            MERR=8
          ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
            READ(CHINL(1:6),*) INDX
            IT=0
            MIRD=0
  330       IT=IT+1
            IF (CHINL(IT:IT).EQ.' ') GOTO 330
C...Don't read index
            IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
              MIRD=1
              GOTO 330
            ENDIF
            IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
            IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
          ELSE
C...  Set unrecognized block flag.
            MERR=6
          ENDIF
 
C...DECAY TABLES
C...Read in decay information
        ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
C...Read new decay chanel
          IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
            NDC=NDC+1
C...Read in branching ratio and number of daughters for this mode.
            READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
            READ(CHINL(4:50),*,ERR=600) DUM, NDA
            IF (NDA.LE.5) THEN
              IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
     &             '(PYSLHA:) Decay data arrays full by KF = '
     $             //CHAF(KC,1))
C...If first decay channel, set decays start point in decay table
              IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
                IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
     &               '* (PYSLHA:) Reading  DECAY table for '//
     &               'KF =',KF,', ',CHAF(KCREP,1)(1:16)
C...Set particle parameters (mass set when reading BLOCK MASS above)
                PMAS(KC,2)=WIDTH
                IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
                  WRITE(MSTU(11),'(1x,A)')
     &                '*  Note: the Pythia gg->h/H/A cross section'//
     &                ' is proportional to the h/H/A->gg width'
                ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
     &                 .OR.KF.EQ.33.OR.KF.EQ.34) THEN
                  WRITE(MSTU(11),'(1x,A,A16)')
     &                 '* Warning: will use DECAY table (fixed-width,'//
     &                 ' flat PS) for ',CHAF(KC,1)(1:16)
                ENDIF
                PMAS(KC,3)=0D0
                PMAS(KC,4)=PARU(3)*1D-12/WIDTH
                MWID(KC)=2
                MDCY(KC,1)=1
                MDCY(KC,2)=NDC
                MDCY(KC,3)=0
C...Add to list of DECAY blocks currently read
                NDECAY=NDECAY+1
                KFDEC(NDECAY)=KF
C...Return ok
                IRETRN=0
              ENDIF
C...  Count up number of decay modes for this particle
              MDCY(KC,3)=MDCY(KC,3)+1
C...  Read in decay daughters.
              READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
C...  Flip sign if reading antiparticle decays (if antipartner exists)
              DO 340 IDA=1,NDA
                IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
     &               IDC(IDA)=MPSIGN*IDC(IDA)
  340         CONTINUE
C...Switch on decay channel, with products ordered in decreasing ABS(KF)
              MDME(NDC,1)=1
              IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
              BRSUM=BRSUM+ABS(BRAT(NDC))
              BRAT(NDC)=ABS(BRAT(NDC))
  350         IFLIP=0
              DO 360 IDA=1,NDA-1
                IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
                  ITMP=IDC(IDA)
                  IDC(IDA)=IDC(IDA+1)
                  IDC(IDA+1)=ITMP
                  IFLIP=IFLIP+1
                ENDIF
  360         CONTINUE
              IF (IFLIP.GT.0) GOTO 350
C...Treat as ordinary decay, no fancy stuff.
              MDME(NDC,2)=0
              DO 370 IDA=1,5
                IF (IDA.LE.NDA) THEN
                  KFDP(NDC,IDA)=IDC(IDA)
                ELSE
                  KFDP(NDC,IDA)=0
                ENDIF
  370         CONTINUE
C              WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
C     &            (KFDP(NDC,J),J=1,NDA)
            ELSE
              CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
     &             CHNLIN)
              MERR=11
              NDC=NDC-1
            ENDIF
          ELSEIF(CHINL(1:1).EQ.'+') THEN
            MERR=11
          ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
            MERR=16
          ELSE
            MERR=16
          ENDIF
        ENDIF
C...  Error check.
  380   IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
          WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
     &         //CHINL(1:40)
          MERR=0
        ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
          WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
     &         CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
        ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
          WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
     &         //CHBLCK(1:INL)//'... on line'//CHNLIN
        ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
     &         CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
          WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
     &         //'... on line'//CHNLIN
        ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
          WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
     &         /CHBLCK(1:INL)//'... on line'//CHNLIN
        ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
          WRITE (CHTMP,*) KF
          WRITE(MSTU(11),*)
     &         '* (PYSLHA:) Ignoring extra MASS entry for KF='//
     &         CHTMP(1:9)//' on line'//CHNLIN
        ENDIF
C...Iterate read loop
        GOTO 170
C...Error catching
  390   WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
     &      ', ignoring subsequent lines.'
        WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
        CHBLCK=' '
        GOTO 170
C...End of read loop
  400   CONTINUE
C...Set flag that KC codes have been rearranged.
        MSTU(20)=0
        VERBOS=0
 
C...Perform possible tests that new information is consistent.
        IF (MUPDA.EQ.1) THEN
          MSTU23=MSTU(23)
          MSTU27=MSTU(27)
C...Check masses
          DO 410 ISUSY=1,37
            KF=KFSUSY(ISUSY)
C...Don't complain about right-handed neutrinos
            IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
     &           +16) GOTO 410
C...Only check gravitino in GMSB scenarios
            IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
            KC=PYCOMP(KF)
            IF (PMAS(KC,1).EQ.0D0) THEN
              WRITE(CHTMP,*) KF
              CALL PYERRM(9
     &             ,'(PYSLHA:) No mass information found for KF ='
     &             //CHTMP)
            ENDIF
  410     CONTINUE
C...Check mixing matrices (MSSM only)
          IF (IMSS(13).EQ.0) THEN
            IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in NMIX')
            IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in UMIX')
            IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in VMIX')
            IF (MSPC(5).NE.4) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
            IF (MSPC(6).NE.4) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
            IF (MSPC(7).NE.4) CALL PYERRM(9
     &           ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
            IF (MSPC(8).LT.1) CALL PYERRM(9
     &           ,'(PYSLHA:) Too few elements in HMIX')
            IF (MSPC(10).EQ.0) CALL PYERRM(9
     &           ,'(PYSLHA:) Missing A_b trilinear coupling')
            IF (MSPC(11).EQ.0) CALL PYERRM(9
     &           ,'(PYSLHA:) Missing A_t trilinear coupling')
            IF (MSPC(12).EQ.0) CALL PYERRM(9
     &           ,'(PYSLHA:) Missing A_tau trilinear coupling')
            IF (MSPC(17).LT.1) CALL PYERRM(9
     &           ,'(PYSLHA:) Missing Higgs mixing angle alpha')
          ENDIF
C...Check wavefunction normalizations.
C...Sfermions
          DO 420 ISPC=5,7
            IF (MSPC(ISPC).EQ.4) THEN
              KFSM=ISPC
              IF (ISPC.EQ.7) KFSM=15
              CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
     &             *SFMIX(KFSM,3))
              IF (ABS(1D0-CHECK).GT.1D-3) THEN
                KCSM=PYCOMP(KFSM)
                CALL PYERRM(17
     &               ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
     &               //CHAF(KCSM,1))
              ENDIF
C...Bug fix 30/09 2008: PS
C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
              IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
                SFMIX(KFSM,3) = -SFMIX(KFSM,3)
                SFMIX(KFSM,4) = -SFMIX(KFSM,4)
              ENDIF
            ENDIF
  420     CONTINUE
C...Neutralinos + charginos
          DO 440 J=1,4
            CN1=0D0
            CN2=0D0
            CU1=0D0
            CU2=0D0
            CV1=0D0
            CV2=0D0
            DO 430 L=1,4
              CN1=CN1+ZMIX(J,L)**2
              CN2=CN2+ZMIX(L,J)**2
              IF (J.LE.2.AND.L.LE.2) THEN
                CU1=CU1+UMIX(J,L)**2
                CU2=CU2+UMIX(L,J)**2
                CV1=CV1+VMIX(J,L)**2
                CV2=CV2+VMIX(L,J)**2
              ENDIF
  430       CONTINUE
C...NMIX normalization
            IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
     &           .GT.1D-3).AND.IMSS(13).EQ.0) THEN
              CALL PYERRM(19,
     &             '(PYSLHA:) NMIX: Inconsistent normalization.')
              WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
            ENDIF
C...UMIX, VMIX normalizations
            IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
              IF (J.LE.2) THEN
                IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
                  CALL PYERRM(19
     &                ,'(PYSLHA:) UMIX: Inconsistent normalization.')
                  WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
     &                 CU2
                ENDIF
                IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
                  CALL PYERRM(19,
     &                '(PYSLHA:) VMIX: Inconsistent normalization.')
                  WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
     &                 CV2
                ENDIF
              ENDIF
            ENDIF
  440     CONTINUE
          IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
            WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
     &           '* (PYSLHA:) No spectrum inconsistencies were found.'
          ELSE
            WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
     &           '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
     &           ,' Warning: one or more (serious)'//
     &           ' inconsistencies were found in the spectrum !'
     &           ,' Read the error messages above and check your'//
     &           ' input file.'
          ENDIF
C...Increase precision in Higgs sector using FeynHiggs
          IF (IMSS(4).EQ.3) THEN
C...FeynHiggs needs MSOFT.
            IERR=0
            IF (MSPC(18).EQ.0) THEN
              WRITE(MSTU(11),'(1x,"*"/1x,A/)')
     &             '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
     &              ' Cannot call FeynHiggs.'
              IERR=-1
            ELSE
              WRITE(MSTU(11),'(1x,/1x,A/)')
     &             '* (PYSLHA:) Now calling FeynHiggs.'
              CALL PYFEYN(IERR)
              IF (IERR.NE.0) IMSS(4)=2
            ENDIF
          ENDIF
        ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
          IBEG=1
          IF (KFORIG.NE.0) IBEG=NDECAY
          DO 490 IDECAY=IBEG,NDECAY
            KF = KFDEC(IDECAY)
            KC = PYCOMP(KF)
            WRITE(CHKF,8300) 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.OR.(MDCY(KC,3)
     $          .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
     $          ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
     $          //CHKF)
            BRSUM=0D0
            BROPN=0D0
            DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
              IF(MDME(IDA,2).GT.80) GOTO 460
              KQ=KCHG(KC,1)
              PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
              MERR=0
              DO 450 J=1,5
                KP=KFDP(IDA,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
  450         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,
     &            '(PYSLHA:) Unknown particle code in decay of KF ='
     $            //CHKF)
              IF(MERR.EQ.2) CALL PYERRM(17,
     &            '(PYSLHA:) Charge not conserved in decay of KF ='
     $            //CHKF)
              IF(MERR.EQ.1) CALL PYERRM(7,
     &            '(PYSLHA:) Kinematically unallowed decay of KF ='
     $            //CHKF)
              BRSUM=BRSUM+BRAT(IDA)
              IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
  460       CONTINUE
C...Check branching ratio sum.
            IF (BROPN.LE.0D0) THEN
C...If zero, set stable.
              WRITE(CHTMP,8500) BROPN
              CALL PYERRM(7
     &            ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
     &            CHTMP(9:16)//'. Changed to stable.')
              PMAS(KC,2)=1D-6
              MWID(KC)=0
C...If BR's > 1, rescale.
            ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
              WRITE(CHTMP,8500) BRSUM
              IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
     &            ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
     &            ' ; sum was'//CHTMP(9:16)//'.')
              FAC=1D0/BRSUM
              DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
                IF(MDME(IDA,2).GT.80) GOTO 470
                BRAT(IDA)=FAC*BRAT(IDA)
  470         CONTINUE
            ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
C...If BR's < 1, insert dummy mode for proper cross section rescaling.
              WRITE(CHTMP,8500) BRSUM
              IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
     &            ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
     &            CHTMP(9:16)//'. Dummy mode will be inserted.')
C...Move table and insert dummy mode
              DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
                NDC=NDC+1
                BRAT(NDC)=BRAT(IDA)
                KFDP(NDC,1)=KFDP(IDA,1)
                KFDP(NDC,2)=KFDP(IDA,2)
                KFDP(NDC,3)=KFDP(IDA,3)
                KFDP(NDC,4)=KFDP(IDA,4)
                KFDP(NDC,5)=KFDP(IDA,5)
                MDME(NDC,1)=MDME(IDA,1)
  480         CONTINUE
              NDC=NDC+1
              BRAT(NDC)=1D0-BRSUM
              KFDP(NDC,1)=0
              KFDP(NDC,2)=0
              KFDP(NDC,3)=0
              KFDP(NDC,4)=0
              KFDP(NDC,5)=0
              MDME(NDC,1)=0
              BRSUM=1D0
C...Update MDCY
              MDCY(KC,3)=MDCY(KC,3)+1
              MDCY(KC,2)=NDC-MDCY(KC,3)+1
            ENDIF
  490     CONTINUE
        ENDIF
 
 
C...WRITE SPECTRUM ON SLHA FILE
      ELSEIF(MUPDA.EQ.3) THEN
C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
        IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
          MODSEL(1)=1
          PARMIN(1)=RMSS(8)
          PARMIN(2)=RMSS(1)
          PARMIN(3)=RMSS(5)
          PARMIN(4)=SIGN(1D0,RMSS(4))
          PARMIN(5)=RMSS(36)
        ENDIF
C...Write spectrum
        WRITE(LFN,7000) 'SLHA MSSM spectrum'
        WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
     &    // ' P. Skands.'
        WRITE(LFN,7010) 'MODSEL',  'Model selection'
        WRITE(LFN,7110) 1, MODSEL(1)
        WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
        IF (MODSEL(1).EQ.1) THEN
          WRITE(LFN,7210) 1, PARMIN(1), 'm0'
          WRITE(LFN,7210) 2, PARMIN(2), 'm12'
          WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
          WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
          WRITE(LFN,7210) 5, PARMIN(5), 'a0'
        ELSEIF(MODSEL(2).EQ.2) THEN
          WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
          WRITE(LFN,7210) 2, PARMIN(2), 'M'
          WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
          WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
          WRITE(LFN,7210) 5, PARMIN(5), 'N5'
          WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
        ENDIF
        WRITE(LFN,7000) ' '
        WRITE(LFN,7010) 'MASS', 'Mass spectrum'
        DO 500 I=1,36
          KF=KFSUSY(I)
          KC=PYCOMP(KF)
          IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
          KFSM=KF-KSUSY1
          IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
            IF (KFSM.EQ.22)  WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
            IF (KFSM.EQ.23)  WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
            IF (KFSM.EQ.25)  WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
            IF (KFSM.EQ.35)  WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
            IF (KFSM.EQ.24)  WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
            IF (KFSM.EQ.37)  WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
          ELSE
            WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
          ENDIF
  500   CONTINUE
C...SUSY scale
        RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
        WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
        WRITE(LFN,7210) 1, RMSS(4),'mu'
        WRITE(LFN,7010) 'ALPHA',' '
        WRITE(LFN,7210) 1, RMSS(18), 'alpha'
        WRITE(LFN,7020) 'AU',RMSUSY
        WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
        WRITE(LFN,7020) 'AD',RMSUSY
        WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
        WRITE(LFN,7020) 'AE',RMSUSY
        WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
        WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
        WRITE(LFN,7410) 1, 1, SFMIX(6,1)
        WRITE(LFN,7410) 1, 2, SFMIX(6,2)
        WRITE(LFN,7410) 2, 1, SFMIX(6,3)
        WRITE(LFN,7410) 2, 2, SFMIX(6,4)
        WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
        WRITE(LFN,7410) 1, 1, SFMIX(5,1)
        WRITE(LFN,7410) 1, 2, SFMIX(5,2)
        WRITE(LFN,7410) 2, 1, SFMIX(5,3)
        WRITE(LFN,7410) 2, 2, SFMIX(5,4)
        WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
        WRITE(LFN,7410) 1, 1, SFMIX(15,1)
        WRITE(LFN,7410) 1, 2, SFMIX(15,2)
        WRITE(LFN,7410) 2, 1, SFMIX(15,3)
        WRITE(LFN,7410) 2, 2, SFMIX(15,4)
        WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
        DO 520 I1=1,4
          DO 510 I2=1,4
            WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
  510     CONTINUE
  520   CONTINUE
        WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
        DO 540 I1=1,2
          DO 530 I2=1,2
            WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
  530     CONTINUE
  540   CONTINUE
        WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
        DO 560 I1=1,2
          DO 550 I2=1,2
            WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
  550     CONTINUE
  560   CONTINUE
        WRITE(LFN,7010) 'SPINFO'
        IF (IMSS(1).EQ.2) THEN
          CPRO(1)='PYTHIA'
          CVER(1)='6.4'
        ELSEIF (IMSS(1).EQ.12) THEN
          ISAVER=VISAJE()
          CPRO(1)='ISASUSY'
          CVER(1)=ISAVER(1:12)
        ENDIF
        WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
        WRITE(LFN,7310) 2, CVER(1), 'Version number'
      ENDIF
 
C...Print user information about spectrum
      IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
        IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
     &       WRITE(MSTU(11),5030) CPRO(1), CVER(1)
        IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
        IF (MUPDA.EQ.1) THEN
          WRITE(MSTU(11),5020) LFN
        ELSE
          WRITE(MSTU(11),5010) LFN
        ENDIF
 
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),5500) 'Pole masses'
        WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
     $       ,(RMFUN(KSUSY2+IP),IP=1,6)
        WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
     $       ,(RMFUN(KSUSY2+IP),IP=11,16)
        IF (IMSS(13).EQ.0) THEN
          WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
     $         ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
     $         RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
          WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
     &         CHAF(37,1), ' ', ' ',' ',' ',
     &         RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
        ELSEIF (IMSS(13).EQ.1) THEN
          KF1=KSUSY1+21
          KF2=KSUSY1+22
          KF3=KSUSY1+23
          KF4=KSUSY1+25
          KF5=KSUSY1+35
          KF6=KSUSY1+45
          KF7=KSUSY1+24
          KF8=KSUSY1+37
          WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
     &         CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
     &         CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
     &         CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
     &         RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
     &         RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
          WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
     &         CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
     &         RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
     &         RMFUN(37)
        ENDIF
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),5500) 'Mixing structure'
        WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
        WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
     &       ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
        WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
     &       ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
     &       ),(SFMIX(15,J),J=3,4)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),5500) 'Couplings'
        WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
        WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),6500)
 
      ENDIF
 
C...Only rewind when reading
      IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
 
 9999 RETURN
 
C...Serious error catching
  580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
      write(*,*) CHINL(1:80)
      CALL PYSTOP(106)
  590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
      WRITE(*,*) CHINL(1:72)
      CALL PYSTOP(106)
  600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
      WRITE(*,*) CHINL(1:80)
      CALL PYSTOP(106)
  610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
      WRITE(*,*) CHINL(1:80)
  620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
      CALL PYSTOP(106)
  630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
      WRITE(*,*) CHINL(1:80)
      CALL PYSTOP(106)
 
 8300 FORMAT(I9)
 8500 FORMAT(F16.5)
 
C...Formats for user information printout.
 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.12: SUSY/BSM SPECTRUM '
     &     ,'INTERFACE',1x,17('*')/1x,'*',1x
     &     ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
     &     3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
     &     ,'----------------')
 5400 FORMAT(1x,'*',1x,A)
 5500 FORMAT(1x,'*',1x,A,':')
 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
     &       1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
     &     4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
     &     ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
     &     ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
     &     ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
     &     ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
     &     ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
     &     ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
     &     ,1x,F6.3,1x),'|')
 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
     &     ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
     &     ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
     &     ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
     &     ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
     &     ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
     &     ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
     &     1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
     &     ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
     &     1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
     &     ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
 6400 FORMAT(1x,'*',3x,'  A_b = ',F8.2,4x,'      A_t = ',F8.2,4x
     &     ,'A_tau = ',F8.2)
 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
     &     ,'   mu = ',F8.2)
 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
 
C...Format to use for comments
 7000 FORMAT('# ',A)
C...Format to use for block statements
 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Int
 7110 FORMAT(1x,I4,1x,I4,3x,'#')
C...Non-Indexed Double
 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Double
 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Long Indexed Double (PDG + double)
 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Indexed Char(12)
 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
C...Single matrix
 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
C...Double Matrix
 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
C...Write Decay Table
 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
     &    3x,'#',1x,A)
 
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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/

      WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
     &' not intended for serious physics studies'
      IMSS(5)=0
      IMSS(8)=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
C...Temporary sign change for AT. Others unchanged.
      AT=-RMSS(16)
      RMSS(15)=RMSS(16)
      RMSS(17)=RMSS(16)
      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
      RMT=PYMRUN(6,PMAS(6,1)**2)
      XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
     &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
      RMB=PYMRUN(5,PMAS(6,1)**2)
      XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
     &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
      XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
      ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
     &SINB)**2)
      RMSS(16)=-ATP
      XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
     &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
      XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
      XMU=SIGN(SQRT(XMU2),RMSS(4))
      RMSS(4)=XMU
      IF(XMA2.GT.0D0) THEN
        RMSS(19)=SQRT(XMA2)
      ELSE
        WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
        CALL PYSTOP(102)
      ENDIF
      ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
      IF(ARG.GT.0D0) THEN
        RMSS(14)=SQRT(ARG)
      ELSE
        WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
        CALL PYSTOP(102)
      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),*) ' PYAPPS::  LEFT STAU MASS**2 < 0 '
        CALL PYSTOP(102)
      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...PYSUGI
C...Interface to ISASUSY version 7.71.
C...Warning: this interface should not be used with earlier versions
C...of ISASUSY, since common block incompatibilities may then arise.
C...Calls SUGRA (in ISAJET) to perform RGE evolution.
C...Then converts to Gunion-Haber conventions.
 
      SUBROUTINE PYSUGI
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
 
      INTEGER PYK,PYCHGE,PYCOMP
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
 
C...Date of Change
      CHARACTER DOC*11
      PARAMETER (DOC='01 May 2006')
 
C...ISASUGRA Input:
      REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
C...XISAIN contains the MSSMi inputs in natural order.
      COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
     $XAMIN(7)
      REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
      SAVE /SUGXIN/
C...ISASUGRA Output
      CHARACTER*40 ISAVER,VISAJE
      REAL SUPER
      COMMON /SSPAR/ SUPER(72)
      COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
     $FBGUT,FTAGUT,FNGUT
      REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
      COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
     $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
     $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
     $VUMT,VDMT,ASMTP,ASMSS,M3Q
      REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
     $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
     $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
      INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
      INTEGER IALLOW
      SAVE /SUGMG/,/SSPAR/
C SUPER: Filled by ISASUGRA.
C SUPER(1)        = mass of ~g
C SUPER(2:17)     = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
C                          ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
C SUPER(18:25)    = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
C                          ,~tau_2
C SUPER(26:28)    = mass of ~nu_e,~nu_mu,~nu_tau
C SUPER(29)       = Higgsino mass = - mu
C SUPER(30)       = ratio v2/v1 of vev's
C SUPER(31:34)    = Signed neutralino masses
C SUPER(35:50)    = Neutralino mixing matrix
C SUPER(51:52)    = Signed chargino masses
C SUPER(53:54)    = Chargino left, right mixing angles
C SUPER(55:58)    = mass of h0, H0, A0, H+
C SUPER(59)       = Higgs mixing angle alpha
C SUPER(60:65)    = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
C SUPER(66)       = Gravitino mass
C SUPER(67:69)    = Top,Bottom, and Tau masses at MSUSY (not used)
C SUPER(70)       = b-Yukawa at mA scale (not used)
C SUPER(71:72)    = H_u, H_d vev's at MSUSY (not used)
C GSS: Filled by ISASUGRA
C     GSS( 1) = g_1        GSS( 2) = g_2        GSS( 3) = g_3
C     GSS( 4) = y_tau      GSS( 5) = y_b        GSS( 6) = y_t
C     GSS( 7) = M_1        GSS( 8) = M_2        GSS( 9) = M_3
C     GSS(10) = A_tau      GSS(11) = A_b        GSS(12) = A_t
C     GSS(13) = M_h12     GSS(14) = M_h22     GSS(15) = M_er2
C     GSS(16) = M_el2     GSS(17) = M_dnr2    GSS(18) = M_upr2
C     GSS(19) = M_upl2    GSS(20) = M_taur2   GSS(21) = M_taul2
C     GSS(22) = M_btr2    GSS(23) = M_tpr2    GSS(24) = M_tpl2
C     GSS(25) = mu         GSS(26) = B          GSS(27) = Y_N
C     GSS(28) = M_nr       GSS(29) = A_n        GSS(30) = log(vdq)
C     GSS(31) = log(vuq)
C MSS: Filled by ISASUGRA
C     MSS( 1) = glss     MSS( 2) = upl      MSS( 3) = upr
C     MSS( 4) = dnl      MSS( 5) = dnr      MSS( 6) = stl
C     MSS( 7) = str      MSS( 8) = chl      MSS( 9) = chr
C     MSS(10) = b1       MSS(11) = b2       MSS(12) = t1
C     MSS(13) = t2       MSS(14) = nuel     MSS(15) = numl
C     MSS(16) = nutl     MSS(17) = el-      MSS(18) = er-
C     MSS(19) = mul-     MSS(20) = mur-     MSS(21) = tau1
C     MSS(22) = tau2     MSS(23) = z1ss     MSS(24) = z2ss
C     MSS(25) = z3ss     MSS(26) = z4ss     MSS(27) = w1ss
C     MSS(28) = w2ss     MSS(29) = hl0      MSS(30) = hh0
C     MSS(31) = ha0      MSS(32) = h+
C Unification, filled by ISASUGRA if applicable.
C     MGUTSS  = M_GUT    GGUTSS  = g_GUT    AGUTSS  = alpha_GUTC
 
C...SPYTHIA Input/Output
      INTEGER IMSS
      DOUBLE PRECISION RMSS
      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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C...SLHA Input/Output
      COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
     &     AU(3,3),AD(3,3),AE(3,3)
C...PYTHIA common blocks
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
 
      SAVE  /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER IMODEL
      REAL M0,MHF,A0,MT
      CHARACTER*20 CHMOD(5)
      CHARACTER*32 FNAME
 
      COMMON /SUGNU/ XNUSUG(18)
      REAL XNUSUG
      SAVE /SUGNU/
 
      DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
     &     'truly unified SUGRA', 'non-minimal GMSB'/
 
C...Start by checking for incompatibilities/inconsistencies:
      DO 100 ICHK=2,9
        IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
          WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
     &         ,' option not used by PYSUGI'
        ENDIF
  100 CONTINUE
C...ISAJET works with REAL numbers.
      MZERO=REAL(RMSS(8))
      MHLF=REAL(RMSS(1))
      AZERO=REAL(RMSS(16))
      TANB=REAL(RMSS(5))
      SGNMU=REAL(RMSS(4))
      MTOP=REAL(PMAS(6,1))
      IMODEL=0
      IF (IMSS(1).EQ.12) THEN
        IMODEL=1
        GOTO 130
      ELSEIF(IMSS(1).EQ.13) THEN
C...Read from isajet par file in IMSS(20)
        LFN=IMSS(20)
C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
        IF (LFN.EQ.0) THEN
          WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
          GOTO 9999
        ENDIF
        WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
CMrenna change to allow any susy model
        WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
        WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
        WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
        WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
     &       ' gauge couplings:'
        WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
        READ(LFN,*) IMODEL
        IF (IMODEL.EQ.4) THEN
          IAL3UN=1
          IMODEL=1
        ENDIF
        IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
          WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
     &         //' sgn(mu), M_t:'
          READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
          IF (IMODEL.EQ.3) THEN
            IMODEL=1
 110        WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
     &           //' 0 to continue:'
            WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
            WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
            WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
            WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
     &           //' generation masses'
            WRITE(MSTU(11),*)
     &           ' NUSUG5 = GUT scale 3rd generation masses'
            READ(LFN,*) INUSUG
            IF (INUSUG.EQ.0) THEN
              GOTO 120
            ELSEIF (INUSUG.EQ.1) THEN
              WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
              READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
              IF (XNUSUG(3).LE.0.) THEN
                WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
                CALL PYSTOP(109)
              END IF
            ELSEIF (INUSUG.EQ.2) THEN
              WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
              READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
            ELSEIF (INUSUG.EQ.3) THEN
              WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
              READ(LFN,*) XNUSUG(7),XNUSUG(8)
            ELSEIF (INUSUG.EQ.4) THEN
              WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
     &             //' M(ur), M(el), M(er):'
              READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
     &             XNUSUG(10),XNUSUG(9)
            ELSEIF (INUSUG.EQ.5) THEN
              WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
     &              //' M(Ll), M(Lr):'
              READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
     &             XNUSUG(15),XNUSUG(14)
            ENDIF
            GOTO 110
          ENDIF
        ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
          IMSS(11)=1
          WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
     &         ,' sgn(mu), M_t, C_gv:'
          READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
          XGMIN(7)=XCMGV
          XGMIN(8)=1.
C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
          AMPL=2.4D18
          AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
          IF (IMODEL.EQ.5) THEN
            IMODEL=2
            WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
     &           ,' masses at M_mes'
            WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
     &           ,' shifts at M_mes'
            WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
     &           ' Y at M_mes'
            WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
     &           ,'SU(2),SU(3)'
            WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
     &           ,' n5_2, n5_3'
            READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
     $           XGMIN(13),XGMIN(14)
          ENDIF
        ELSE
          WRITE(MSTU(11),*) 'Invalid model choice.'
          GOTO 9999
        ENDIF
      ENDIF
 
 120  MZERO=M0
      MHLF=MHF
      AZERO=A0
C     TANB=REAL(RMSS(5))
C     SGNMU=REAL(RMSS(4))
      MTOP=MT
 
C...Initialize MSSM parameter array
 130  DO 140 IPAR=1,72
        SUPER(IPAR)=0.0
 140  CONTINUE
C...Call ISASUGRA
      CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
C...Check whether ISASUSY thought the model was OK.
      IF (NOGOOD.NE.0) THEN
        IF (NOGOOD.EQ.1) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
        IF (NOGOOD.EQ.2) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give no EWSB.')
        IF (NOGOOD.EQ.3) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
        IF (NOGOOD.EQ.4) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
        IF (NOGOOD.EQ.7) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
        IF (NOGOOD.EQ.8) CALL PYERRM(26
     &       ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
C...Give warning, but don't stop, if LSP not ~chi_10.
        IF (NOGOOD.EQ.5) CALL PYERRM(16
     &       ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
      ENDIF
C...Warn about possible GUT scale tachyons.
      IF (ITACHY.NE.0) CALL PYERRM(16,
     &       '(PYSUGI:) Tachyonic sleptons at GUT scale.')
C...Finalize spectrum (last iteration)
C...(Thanks to A. Raklev for pointing this out.)
C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
      CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
     $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
     $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
     $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
     $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
     $ MTOP,IALLOW,1)
 
C...M1, M2, M3.
      RMSS(1)=dble(GSS(7))
      RMSS(2)=dble(GSS(8))
      RMSS(3)=dble(GSS(9))
      RMSOFT(1)=dble(GSS(7))
      RMSOFT(2)=dble(GSS(8))
      RMSOFT(3)=dble(GSS(9))
C...Mu = - Higgsino mass.
      RMSS(4)=-SUPER(29)
      RMSS(5)=TANB
C...Slepton and squark masses. 2 first generations.
      RMSS(6)=0.5*(SUPER(18)+SUPER(20))
      RMSS(7)=0.5*(SUPER(19)+SUPER(21))
      RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
      RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
C...Third generation.
      RMSS(10)=0.5*(SUPER(14)+SUPER(10))
      RMSS(11)=SUPER(11)
      RMSS(12)=SUPER(15)
      RMSS(13)=SUPER(22)
      RMSS(14)=SUPER(23)
C...SLHA: store exact soft spectrum in RMSOFT
      RMSOFT(31)=SUPER(18)
      RMSOFT(32)=SUPER(20)
      RMSOFT(33)=SUPER(22)
      RMSOFT(34)=SUPER(19)
      RMSOFT(35)=SUPER(21)
      RMSOFT(36)=SUPER(23)
      RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
      RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
      RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
      RMSOFT(44)=SUPER(3)
      RMSOFT(45)=SUPER(9)
      RMSOFT(46)=SUPER(15)
      RMSOFT(47)=SUPER(5)
      RMSOFT(48)=SUPER(7)
      RMSOFT(49)=SUPER(11)
 
C...~b, ~t, and ~tau trilinear couplings and mixing angles.
      RMSS(15)=SUPER(62)
      RMSS(16)=SUPER(60)
      RMSS(17)=SUPER(64)
      RMSS(26)=SUPER(63)
      RMSS(27)=SUPER(61)
      RMSS(28)=SUPER(65)
C...SLHA trilinears
      DO 142 K1=1,3
        DO 141 K2=1,3
          AE(K1,K2)=0D0
          AU(K1,K2)=0D0
          AD(K1,K2)=0D0
 141    CONTINUE
 142  CONTINUE
      AE(3,3)=SUPER(64)
      AU(3,3)=SUPER(60)
      AD(3,3)=SUPER(62)
C...Higgs mixing angle alpha (Gunion-Haber convention).
      RMSS(18)=-SUPER(59)
C...A0 mass.
      RMSS(19)=SUPER(57)
C...GUT scale coupling
      RMSS(20)=AGUTSS
C...Gravitino mass (for future compatibility)
      RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
 
C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
C...Higgs sector.
      PMAS(PYCOMP(25),1)=ABS(SUPER(55))
      PMAS(PYCOMP(35),1)=ABS(SUPER(56))
      PMAS(PYCOMP(36),1)=ABS(SUPER(57))
      PMAS(PYCOMP(37),1)=ABS(SUPER(58))
C...Gluino.
      PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
C...Squarks and Sleptons.
      DO 150 ILR=1,2
        ILRM=ILR-1
        PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
        PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
  150 CONTINUE
      PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
      PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
      PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
C...Neutralinos.
      PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
      PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
      PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
      PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
C...Signed masses (extra minus from going to G-H convention).
      SMZ(1)=-SUPER(31)
      SMZ(2)=-SUPER(32)
      SMZ(3)=-SUPER(33)
      SMZ(4)=-SUPER(34)
C...Charginos
      PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
      PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
C...Signed masses (extra minus from going to G-H convention).
      SMW(1)=-SUPER(51)
      SMW(2)=-SUPER(52)
 
C... Neutralino Mixing.
      DO 160 IN=1,4
        ZMIX(IN,1)= SUPER(38+4*(IN-1))
        ZMIX(IN,2)= SUPER(37+4*(IN-1))
        ZMIX(IN,3)=-SUPER(36+4*(IN-1))
        ZMIX(IN,4)=-SUPER(35+4*(IN-1))
  160 CONTINUE
C...Chargino Mixing (PYTHIA same angle as HERWIG).
      THX=1D0
      THY=1D0
      IF (SUPER(53).GT.0) THX=-1D0
      IF (SUPER(54).GT.0) THY=-1D0
      UMIX(1,1) = -SIN(SUPER(53))
      UMIX(1,2) = -COS(SUPER(53))
      UMIX(2,1) = -THX*COS(SUPER(53))
      UMIX(2,2) = THX*SIN(SUPER(53))
      VMIX(1,1) = -SIN(SUPER(54))
      VMIX(1,2) = -COS(SUPER(54))
      VMIX(2,1) = -THY*COS(SUPER(54))
      VMIX(2,2) = THY*SIN(SUPER(54))
C...Sfermion mixing (PYTHIA same angle as ISAJET)
      SFMIX(5,1)=COS(SUPER(63))
      SFMIX(5,2)=SIN(SUPER(63))
      SFMIX(5,3)=-SIN(SUPER(63))
      SFMIX(5,4)=COS(SUPER(63))
      SFMIX(6,1)=COS(SUPER(61))
      SFMIX(6,2)=SIN(SUPER(61))
      SFMIX(6,3)=-SIN(SUPER(61))
      SFMIX(6,4)=COS(SUPER(61))
      SFMIX(15,1)=COS(SUPER(65))
      SFMIX(15,2)=SIN(SUPER(65))
      SFMIX(15,3)=-SIN(SUPER(65))
      SFMIX(15,4)=COS(SUPER(65))
 
      IF (MSTP(122).NE.0) THEN
C...Print a few lines to make the user know what's happening
        ISAVER=VISAJE()
        WRITE(MSTU(11),5000) DOC, ISAVER
        WRITE(MSTU(11),5100)
        IF (IMODEL.EQ.1) THEN
          WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
     &         MTOP
          WRITE(MSTU(11),5300)
        ENDIF
        WRITE(MSTU(11),5500) 'Pole masses'
        WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
        WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
     &       ,(SUPER(IP),IP=19,25,2)
        WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
     &       ,IP=1,2)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),5500) 'EW scale mixing structure'
        WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
        WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
     &       ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
        WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
     &       ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
     &       ),(SFMIX(15,J),J=3,4)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),6450) RMSS(18)
        WRITE(MSTU(11),5400)
        WRITE(MSTU(11),5500) 'Couplings'
        WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
        WRITE(MSTU(11),5400)
      ENDIF
 
C...Call FeynHiggs to improve Higgs sector if requested
      IF (IMSS(4).EQ.3) THEN
        IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
     &       ' (PYSUGI:) Now calling FeynHiggs.'
        CALL PYFEYN(IERR)
        IF (IERR.EQ.0) THEN
          IMSS(4)=2
          IF (MSTP(122).NE.0) THEN
            WRITE(MSTU(11),5400)
            WRITE(MSTU(11),5500)
     &           'Corrected Higgs masses and mixing'
            WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
     &           PMAS(37,1)
            WRITE(MSTU(11),6450) RMSS(18)
            WRITE(MSTU(11),5400)
          ENDIF
        ENDIF
      ENDIF
 
      IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
 
C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
C...output by ISASUSY.
      IMSS(4)=MAX(2,IMSS(4))
 
 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
     &     ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
     &     ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
     &     3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
     &     ,'----------------')
 5400 FORMAT(1x,'*',1x,A)
 5500 FORMAT(1x,'*',1x,A,':')
 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
     &       1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
     &     4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
     &     '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
     &     ,1x))
 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
     &     ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
     &     ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
     &     .2,1x))
 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
     &     ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
     &     ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
     &     ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
     &     ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
     &     ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
     &     ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
     &     ,1x,F6.3,1x),'|')
 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
     &     ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
     &     ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
     &     ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
     &     ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
     &     ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
     &     ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
     &     1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
     &     ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
     &     1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
     &     ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
     &     ,4x,'Alpha_GUT = ',F8.2)
 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
 
 9999 RETURN
      END
 
C*********************************************************************
 
C...PYFEYN
C...Interface to FeynHiggs for MSSM Higgs sector.
C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
C...P. Skands
 
      SUBROUTINE PYFEYN(IERR)
 
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)
C...SUSY blocks
      COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
C...FeynHiggs variables
      DOUBLE PRECISION RMHIGG(4)
      DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
      DOUBLE COMPLEX DMU,
     &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
     &     DM1, DM2, DM3
C...SLHA Common Block
      COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
     &     AU(3,3),AD(3,3),AE(3,3)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
 
      IERR=0
      CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
      IF (IERR.NE.0) THEN
        CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
     &       //'Will not use FeynHiggs for this run.')
        RETURN
      ENDIF
      Q=RMSOFT(0)
      DMB=PMAS(5,1)
      DMT=PMAS(6,1)
      DMZ=PMAS(23,1)
      DMW=PMAS(24,1)
      DMA=PMAS(36,1)
      DM1=RMSOFT(1)
      DM2=RMSOFT(2)
      DM3=RMSOFT(3)
      DTANB=RMSS(5)
      DMU=RMSS(4)
      DM3SL=RMSOFT(33)
      DM3SE=RMSOFT(36)
      DM3SQ=RMSOFT(43)
      DM3SU=RMSOFT(46)
      DM3SD=RMSOFT(49)
      DM2SL=RMSOFT(32)
      DM2SE=RMSOFT(35)
      DM2SQ=RMSOFT(42)
      DM2SU=RMSOFT(45)
      DM2SD=RMSOFT(48)
      DM1SL=RMSOFT(31)
      DM1SE=RMSOFT(34)
      DM1SQ=RMSOFT(41)
      DM1SU=RMSOFT(44)
      DM1SD=RMSOFT(47)
      AE33=AE(3,3)
      AE22=AE(2,2)
      AE11=AE(1,1)
      AU33=AU(3,3)
      AU22=AU(2,2)
      AU11=AU(1,1)
      AD33=AD(3,3)
      AD22=AD(2,2)
      AD11=AD(1,1)
      CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
     &     DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
     &     DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
     &     DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
     &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
     &     DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
      IF (IERR.NE.0) THEN
        CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
     &       //' Will not use FeynHiggs for this run.')
        RETURN
      ENDIF
C...  Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
      SAEFF=0D0
      CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
      IF (IERR.NE.0) THEN
        CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
     &       'GSCORR. Will not use FeynHiggs for this run.')
        RETURN
      ENDIF
      ALPHA = ASIN(DBLE(SAEFF))
      R=RMSS(18)/ALPHA
      IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
        CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
        WRITE(MSTU(11),*) '   Old Alpha:', RMSS(18)
        WRITE(MSTU(11),*) '   New Alpha:', ALPHA
      ENDIF
      IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
     &       1.15D0*PMAS(25,1)) THEN
        CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
        WRITE(MSTU(11),*) '   Old m(h0):', PMAS(25,1)
        WRITE(MSTU(11),*) '   New m(h0):', RMHIGG(1)
      ENDIF
      RMSS(18)=ALPHA
      PMAS(25,1)=RMHIGG(1)
      PMAS(35,1)=RMHIGG(2)
      PMAS(36,1)=RMHIGG(3)
      PMAS(37,1)=RMHIGG(4)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRNMQ
C...Determines the running mass of Squarks.
 
      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...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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
 
C...Local variables.
      DOUBLE PRECISION BETA
      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 ATR,AMQR,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=DCOS(RMSS(27))
        CTT2=CTT**2
        STT=DSIN(RMSS(27))
        STT2=STT**2
        XM12=RMSS(10)**2
        XM22=RMSS(12)**2
        XMQL2=CTT2*XM12+STT2*XM22
        XMQR2=STT2*XM12+CTT2*XM22
        XMF2=PYMRUN(6,PMAS(6,1)**2)**2
        ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
        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=DCOS(RMSS(26))
        CTT2=CTT**2
        STT=DSIN(RMSS(26))
        STT2=STT**2
        XM22=RMSS(11)**2
        XMF2=PYMRUN(5,PMAS(6,1)**2)**2
        XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
        IF(ABS(CTT).GE..9999D0) THEN
          ABOT=-XMU*TANB
          XMQR2=RMSS(11)**2
        ELSEIF(ABS(CTT).LE.1D-4) THEN
          ABOT=-XMU*TANB
          XMQR2=RMSS(11)**2
        ELSE
          XM12=(XMQL2-STT2*XM22)/CTT2
          XMQR2=STT2*XM12+CTT2*XM22
          ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/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=DCOS(RMSS(28))
        CTT2=CTT**2
        STT=DSIN(RMSS(28))
        STT2=STT**2
        XM12=RMSS(13)**2
        XM22=RMSS(14)**2
        XMQL2=CTT2*XM12+STT2*XM22
        XMQR2=STT2*XM12+CTT2*XM22
        XMFR=PMAS(15,1)
        XMF2=XMFR**2
        ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
        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
        ATR=RMSS(ID3(L))
        AMQR=RMSS(ID4(L))
        IF(AMQR.LT.0D0) THEN
          XMQR2=-AMQR**2
        ELSE
          XMQR2=AMQR**2
        ENDIF
        IF=ID2(L)
        XMF=PYMRUN(IF,PMAS(6,1)**2)
        XMF2=XMF**2
        AM2(1,1)=XMQL2+XMF2
        AM2(2,2)=XMQR2+XMF2
        IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
        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,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
              AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
              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),*) ID2(L),DETM,AM2
          CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
        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 '
          CALL PYSTOP(111)
        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
 
C.....TAU SNEUTRINO MASS...L=3
 
      XARG=AM2(1,1)+XMW2*COS2B
      IF(XARG.LT.0D0) THEN
        WRITE(MSTU(11),*) ' PYTHRG:: 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
 
      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 PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
 
C...Local variables.
      DOUBLE PRECISION XMW,XMZ,XM(4)
      DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
      DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
      DOUBLE PRECISION COSW,SINW
      DOUBLE PRECISION XMU
      DOUBLE PRECISION TANB,COSB,SINB
      DOUBLE PRECISION XM1,XM2,XM3,BETA
      DOUBLE PRECISION Q2,AEM,A1,A2,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
      COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
      INTEGER IERR,INDEX(4),I,J,K,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
          CALL PYSTOP(105)
        ENDIF
      ENDIF
 
C...GLUINO MASS
      IF(IMSS(3).EQ.1) THEN
        PMAS(PYCOMP(KSUSY1+21),1)=ABS(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)=ABS(XM3)*(1D0+PYALPS(XM3**2)
     &  /(2D0*PARU(2))*(15D0+AQ))
      ENDIF
 
C...NEUTRALINO MASSES
      DO 150 I=1,4
        DO 140 J=1,4
          AI(I,J)=0D0
  140   CONTINUE
  150 CONTINUE
      XMZ=PMAS(23,1)/100D0
      XMW=PMAS(24,1)/100D0
      XMU=RMSS(4)/100D0
      SINW=SQRT(PARU(102))
      COSW=SQRT(1D0-PARU(102))
      TANB=RMSS(5)
      BETA=ATAN(TANB)
      COSB=COS(BETA)
      SINB=TANB*COSB

      XM2=XM2/100D0
      XM1=XM1/100D0
      
 
C... Definitions:
C...    psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
      AR(1,1) = XM1*COS(RMSS(30))
      AI(1,1) = XM1*SIN(RMSS(30))
      AR(2,2) = XM2*COS(RMSS(31))
      AI(2,2) = XM2*SIN(RMSS(31))
      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*COS(RMSS(33))
      AI(3,4) = -XMU*SIN(RMSS(33))
      AR(4,3) = -XMU*COS(RMSS(33))
      AI(4,3) = -XMU*SIN(RMSS(33))
C      CALL PYEIG4(AR,WR,ZR)
      CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
      IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
     & 'PROBLEM WITH PYEICG IN PYINOM ')
      DO 160 I=1,4
        INDEX(I)=I
        XM(I)=ABS(WR(I))
  160 CONTINUE
      DO 180 I=2,4
        K=I
        DO 170 J=I-1,1,-1
          IF(XM(K).LT.XM(J)) THEN
            ITMP=INDEX(J)
            XTMP=XM(J)
            INDEX(J)=INDEX(K)
            XM(J)=XM(K)
            INDEX(K)=ITMP
            XM(K)=XTMP
            K=K-1
          ELSE
            GOTO 180
          ENDIF
  170   CONTINUE
  180 CONTINUE
 
 
      DO 210 I=1,4
        K=INDEX(I)
        SMZ(I)=WR(K)*100D0
        PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
        S=0D0
        DO 190 J=1,4
          S=S+ZR(J,K)**2+ZI(J,K)**2
  190   CONTINUE
        DO 200 J=1,4
          ZMIX(I,J)=ZR(J,K)/SQRT(S)
          ZMIXI(I,J)=ZI(J,K)/SQRT(S)
          IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
          IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
  200   CONTINUE
  210 CONTINUE
 
C...CHARGINO MASSES
C.....Find eigenvectors of X X^*
      DO I=1,4
        DO J=1,4
          AR(I,J)=0D0
          AI(I,J)=0D0
        ENDDO
      ENDDO
      AI(1,1) = 0D0
      AI(2,2) = 0D0
      AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
      AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
      AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
     &XMU*COS(RMSS(33))*SINB)
      AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
     &XMU*SIN(RMSS(33))*SINB)
      AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
     &XMU*COS(RMSS(33))*SINB)
      AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
     &XMU*SIN(RMSS(33))*SINB)
      CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
      IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
     & 'PROBLEM WITH PYEICG IN PYINOM ')
      INDEX(1)=1
      INDEX(2)=2
      IF(WR(2).LT.WR(1)) THEN
        INDEX(1)=2
        INDEX(2)=1
      ENDIF

 
      DO 240 I=1,2
        K=INDEX(I)
        SMW(I)=SQRT(WR(K))*100D0
        S=0D0
        DO 220 J=1,2
          S=S+ZR(J,K)**2+ZI(J,K)**2
  220   CONTINUE
        DO 230 J=1,2
          UMIX(I,J)=ZR(J,K)/SQRT(S)
          UMIXI(I,J)=-ZI(J,K)/SQRT(S)
          IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
          IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
  230   CONTINUE
  240 CONTINUE
C...Force chargino mass > neutralino mass
      IFRC=0
      IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
        CALL PYERRM(8,'(PYINOM:) '//
     &      'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
        SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
        IFRC=1
      ENDIF
      PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
      PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
 
C.....Find eigenvectors of X^* X
      DO I=1,4
        DO J=1,4
          AR(I,J)=0D0
          AI(I,J)=0D0
          ZR(I,J)=0D0
          ZI(I,J)=0D0
        ENDDO
      ENDDO
      AI(1,1) = 0D0
      AI(2,2) = 0D0
      AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
      AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
      AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
     &XMU*COS(RMSS(33))*COSB)
      AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
     &XMU*SIN(RMSS(33))*COSB)
      AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
     &XMU*COS(RMSS(33))*COSB)
      AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
     &XMU*SIN(RMSS(33))*COSB)
      CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
      IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
     & 'PROBLEM WITH PYEICG IN PYINOM ')
      INDEX(1)=1
      INDEX(2)=2
      IF(WR(2).LT.WR(1)) THEN
        INDEX(1)=2
        INDEX(2)=1
      ENDIF
 
      SIMAG=0D0
      DO 270 I=1,2
        K=INDEX(I)
        S=0D0
        DO 250 J=1,2
          S=S+ZR(J,K)**2+ZI(J,K)**2
          SIMAG=SIMAG+ZI(J,K)**2
  250   CONTINUE
        DO 260 J=1,2
          VMIX(I,J)=ZR(J,K)/SQRT(S)
          VMIXI(I,J)=-ZI(J,K)/SQRT(S)
          IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
          IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
  260   CONTINUE
  270 CONTINUE

C.....Simplify if no phases
      IF(SIMAG.LT.1D-6) THEN
        AR(1,1) = XM2*COS(RMSS(31))
        AR(2,2) = XMU*COS(RMSS(33))
        AR(1,2) = SQRT(2D0)*XMW*SINB
        AR(2,1) = SQRT(2D0)*XMW*COSB
        IKNT=0
 300    CONTINUE
        DO I=1,2
          DO J=1,2
            ZR(I,J)=0D0
          ENDDO
        ENDDO

        DO I=1,2
          DO J=1,2
            DO K=1,2
              DO L=1,2
                ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
        VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
        VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
        VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
        VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
        IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
          CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
        ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
          IKNT=IKNT+1
          GOTO 300
        ENDIF
C.....Must deal with phases
      ELSE
        CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
        CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
        CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
        CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)

        IKNT=0
 310    CONTINUE
        DO I=1,2
          DO J=1,2
            CAI(I,J)=CMPLX(0D0,0D0)
          ENDDO
        ENDDO

        DO I=1,2
          DO J=1,2
            DO K=1,2
              DO L=1,2
                CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
     &           CMPLX(VMIX(J,L),VMIXI(J,L))
              ENDDO
            ENDDO
          ENDDO
        ENDDO

        CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
        CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
        TEMPR=VMIX(1,1)
        TEMPI=VMIXI(1,1)
        VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
        VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
        TEMPR=VMIX(1,2)
        TEMPI=VMIXI(1,2)
        VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
        VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
        TEMPR=VMIX(2,1)
        TEMPI=VMIXI(2,1)
        VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
        VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
        TEMPR=VMIX(2,2)
        TEMPI=VMIXI(2,2)
        VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
        VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
        IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
          CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
        ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
     &   ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
          IKNT=IKNT+1
          GOTO 310
        ENDIF
      ENDIF 
      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 R
      DOUBLE PRECISION TOL
      EXTERNAL PYALPS
      DOUBLE PRECISION PYALPS
      DATA TOL/0.001D0/
      DATA R/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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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
      DOUBLE PRECISION ALPHA
      INTEGER IHOPT
      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)
      DMGL=RMSS(3)
      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
      RMSS(40)=0D0
      RMSS(41)=0D0
 
      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,DMGL,DDT,DDB)
        RMSS(40)=DDT
        RMSS(41)=DDB
        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
 
      ELSEIF (IHOPT.EQ.3) THEN
c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
C...Currently only available for SLHA spectrum read-in.
        IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
          CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
     &         //' spectrum, change IMSS(1) or IMSS(4) option.')
        ENDIF
        ALPHA=RMSS(18)
        RETURN
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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 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 = PYMRUN(5,XMTOP**2)
      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)
C      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 number of
C...Higgses whose pole mass is computed. 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. above). If IHIGGS=1,
C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
c...and 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,XMG,DT,DB)
 
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)
      SAVE /PYDAT1/
      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=PARU(1)
      RXMT=PYMRUN(6,XMT**2)
      CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
     &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
 
      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 = PYMRUN(5,XMT**2)
      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
C      WMST11 = RXMT**2 + XMQ2
C      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
C      STOP1W = STOP1
C      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 = DSQRT(2D0)
      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
C        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.500) GOTO 240
      GOTO 180
  240 CONTINUE
 
      XMHP = DSQRT(P2)
 
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
 
C        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.500) 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
C        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.500) GOTO 480
      GOTO 420
  480 CONTINUE
 
      AMP = DSQRT(AP2)
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C...END OF PSEUDOSCALAR HIGGS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      IF(IHIGGS.EQ.3) GOTO 490
 
  490 CONTINUE
      RETURN
  500 CONTINUE
      WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
      WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
      WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
      WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
      CALL PYSTOP(107)
      END
 
C*********************************************************************
 
C...PYRGHM
C...Auxiliary to PYPOLE.
 
      SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
     *    MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
      IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
      DIMENSION VH(2,2),M2(2,2),M2P(2,2)
C...Parameters.
      INTEGER MSTU,MSTJ
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
      MZ = 91.18D0
      PI = PARU(1)
      V  = 174.1D0
      ALPHA1 = 0.0101D0
      ALPHA2 = 0.0337D0
      ALPHA3Z = 0.12D0
      TANBA = TANB
      TANBT = TANB
C     MBOTTOM(MTOP) = 3. GEV
      MB = PYMRUN(5,MTOP**2)
      ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
     *LOG(MTOP**2/MZ**2))
C     RMTOP= RUNNING TOP QUARK MASS
      RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
      TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
      TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
      TD = LOG((MD**2 + MTOP**2)/MTOP**2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C    NEW DEFINITION, TGLU.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      TGLU = LOG(MGLU**2/MTOP**2)
      SINB = TANB/DSQRT(1D0 + TANB**2)
      COSB = SINB/TANB
      IF(MA.GT.MTOP)
     *TANBA = TANB*(1D0-3D0/32D0/PI**2*
     *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
     *LOG(MA**2/MTOP**2))
      IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
      SINB = TANBT/SQRT(1D0 + TANBT**2)
      COSB = 1D0/DSQRT(1D0 + TANBT**2)
      G1 = SQRT(ALPHA1*4D0*PI)
      G2 = SQRT(ALPHA2*4D0*PI)
      G3 = SQRT(ALPHA3*4D0*PI)
      HU = RMTOP/V/SINB
      HD =  MB/V/COSB
      CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
     *SBOT1,SBOT2,DELTAMT,DELTAMB)
      IF(MQ.GT.MUR) TP = TQ - TU
      IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
      IF(MQ.GT.MUR) TDP = TU
      IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
      IF(MQ.GT.MD) TPD = TQ - TD
      IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
      IF(MQ.GT.MD) TDPD = TD
      IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
 
      IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
      IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
     * HD**2*(G1**2/3D0+G2**2)*TPD
 
      IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
      IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
     * HU**2*(-G1**2/3D0+G2**2)*TP
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
C  THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
C  AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
C  TWO STOPS.
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      DLAMBDAP2 = 0D0
      IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
       IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
       ENDIF
 
       IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
       ENDIF
 
       IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
       ENDIF
 
       IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
       ENDIF
 
       IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
       ENDIF
 
       IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
        DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
       ENDIF
      ENDIF
      DLAMBDA3 = 0D0
      DLAMBDA4 = 0D0
      IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
      IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
     *(G2**2-G1**2/3D0)*TPD
      IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
     *1D0/16D0/PI**2*G1**2*HU**2*TP
      IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
     * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
      IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
      IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
     *HD**2*TPD
      LAMBDA1 = ((G1**2 + G2**2)/4D0)*
     * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
     *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
     *+ (3D0*HD**2/2D0 + HU**2/2D0
     *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
     *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0  + (3D0*HD**2/2D0 + HU**2/2D0
     *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
      LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
     *(TP + TDP)/8D0/PI**2)
     *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
     *+ (3D0*HU**2/2D0 + HD**2/2D0
     *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
     *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
     *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
      LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
     *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
     *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
      LAMBDA4 = (- G2**2/2D0)*(1D0
     *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
     *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
 
      LAMBDA5 = 0D0
      LAMBDA6 = 0D0
      LAMBDA7 = 0D0
 
      M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
     *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
 
      M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
     *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
      M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
     *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
 
      M2(2,1) = M2(1,2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC  THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
 
      IF(MCHI.GT.MSSUSY) GOTO 100
      IF(MCHI.LT.MTOP) MCHI=MTOP
 
      TCHAR=LOG(MSSUSY**2/MCHI**2)
 
      DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
      DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
     *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
 
      DELTAM112=2D0*DELTAL12*V**2*COSB**2
      DELTAM222=2D0*DELTAL12*V**2*SINB**2
      DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
 
      M2(1,1)=M2(1,1)+DELTAM112
      M2(2,2)=M2(2,2)+DELTAM222
      M2(1,2)=M2(1,2)+DELTAM122
      M2(2,1)=M2(2,1)+DELTAM122
 
  100 CONTINUE
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC  END OF CHARGINOS/NEUTRALINOS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      DO 120 I = 1,2
        DO 110 J = 1,2
          M2P(I,J) = M2(I,J) + VH(I,J)
  110   CONTINUE
  120 CONTINUE
      TRM2P = M2P(1,1) + M2P(2,2)
      DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
      MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
      HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
      HMP = DSQRT(HM2P)
      MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
      MCH=DSQRT(MCH2)
      IF(MH2P.LT.0.) GOTO 130
      MHP = SQRT(MH2P)
      SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
      COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
      IF(COS2ALPHA.GE.0.) THEN
        ALPHA = ASIN(SIN2ALPHA)/2D0
      ELSE
        ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
      ENDIF
      SA = SIN(ALPHA)
      CA = COS(ALPHA)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C        HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
C        TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
C        HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
      CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
  130 CONTINUE
      RETURN
      END
 
C*********************************************************************
 
C...PYGFXX
C...Auxiliary to PYRGHM.
 
      SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
     *  STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
      IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
      DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
C...Commonblocks.
      INTEGER MSTU,MSTJ,KCHG
      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/
 
      G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
 
      T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
     * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
 
      IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
      MQ2 = MQ**2
      MUR2 = MUR**2
      MD2 = MD**2
      TANBA = TANB
      SINBA = TANBA/DSQRT(TANBA**2+1D0)
      COSBA = SINBA/TANBA
 
      SINB = TANB/DSQRT(TANB**2+1D0)
      COSB = SINB/TANB
 
      PI = PARU(1)
      MZ = PMAS(23,1)
      MW = PMAS(24,1)
      SW = 1D0-MW**2/MZ**2
      V  = 174.1D0
 
      ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
      G2 = DSQRT(0.0336D0*4D0*PI)
      G1 = DSQRT(0.0101D0*4D0*PI)
 
      IF(MQ.GT.MUR) MST = MQ
      IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
 
      MSUSYT = DSQRT(MST**2  + MTOP**2)
 
      IF(MQ.GT.MD) MSB = MQ
      IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
 
      MB = PYMRUN(5,MSB**2)
      MSUSYB = DSQRT(MSB**2 + MB**2)
      TT = LOG(MSUSYT**2/MTOP**2)
      TB = LOG(MSUSYB**2/MTOP**2)
 
      RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
      HT = RMTOP/(V*SINB)
      HTST = RMTOP/V
      HB = MB/V/COSB
      G32 = ALPHA3*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
C      BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
C      ALST = 3./8./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
 
      IF(MA.GT.MTOP) THEN
        VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
     *        LOG(MTOP**2/MA**2))
        H1I = VI* COSBA
        H2I = VI*SINBA
        H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
        H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
        H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
        H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
      ELSE
        VI = V
        H1I = VI*COSB
        H2I = VI*SINB
        H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
        H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
        H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
        H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
      ENDIF
 
      TANBST = H2T/H1T
      SINBT = TANBST/DSQRT(1D0+TANBST**2)
 
      TANBSB = H2B/H1B
      SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
      COSBB = SINBB/TANBSB
 
      DELTAMT = 0D0
      DELTAMB = 0D0
 
      MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
      MTOP2 = DSQRT(MTOP4)
      MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
     * /(1D0+DELTAMB)**4
      MBOT2 = DSQRT(MBOT4)
 
      STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
     *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
     *  +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
     *  MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
      STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
     *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
     *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
     *  MQ2 - MUR2)**2*0.25D0
     *  + MTOP2*(AT-XMU/TANBST)**2)
      IF(STOP22.LT.0.) GOTO 120
      SBOT12 = (MQ2 + MD2)*.5D0
     *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
     *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
     *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
      SBOT22 = (MQ2 + MD2)*.5D0
     *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
     *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
     *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
      IF(SBOT22.LT.0.) SBOT22 = 10000D0
 
      STOP1 = DSQRT(STOP12)
      STOP2 = DSQRT(STOP22)
      SBOT1 = DSQRT(SBOT12)
      SBOT2 = DSQRT(SBOT22)
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
C     ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
C     MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
C     INDUCED CORRECTIONS.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      X=SBOT1
      Y=SBOT2
      Z=XMGL
      IF(X.EQ.Y) X = X - 0.00001D0
      IF(X.EQ.Z) X = X - 0.00002D0
      IF(Y.EQ.Z) Y = Y - 0.00003D0
 
      T1=T(X,Y,Z)
      X=STOP1
      Y=STOP2
      Z=XMU
      IF(X.EQ.Y) X = X - 0.00001D0
      IF(X.EQ.Z) X = X - 0.00002D0
      IF(Y.EQ.Z) Y = Y - 0.00003D0
      T2=T(X,Y,Z)
      DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
     *  + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
      X=STOP1
      Y=STOP2
      Z=XMGL
      IF(X.EQ.Y) X = X - 0.00001D0
      IF(X.EQ.Z) X = X - 0.00002D0
      IF(Y.EQ.Z) Y = Y - 0.00003D0
      T3=T(X,Y,Z)
      DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
C   THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
C   POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
C   INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
C   THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
C   TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
C   S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
C   D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
C   QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
C   FORMULATION.  THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
C   CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
      MTOP2 = DSQRT(MTOP4)
      MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
     * /(1D0+DELTAMB)**4
      MBOT2 = DSQRT(MBOT4)
 
      STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
     *   +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
     *   +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
     *   MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
      STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
     *  +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
     *   - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
     *  MQ2 - MUR2)**2*0.25D0
     *  + MTOP2*(AT-XMU/TANBST)**2)
 
      IF(STOP22.LT.0.) GOTO 120
      SBOT12 = (MQ2 + MD2)*.5D0
     *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
     *  + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
     *  MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
      SBOT22 = (MQ2 + MD2)*.5D0
     *   - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
     *   - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
     *   MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
      IF(SBOT22.LT.0.) GOTO 120
 
 
      STOP1 = DSQRT(STOP12)
      STOP2 = DSQRT(STOP22)
      SBOT1 = DSQRT(SBOT12)
      SBOT2 = DSQRT(SBOT22)
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC   D-TERMS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      STW=SW
 
      F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
     *         LOG(STOP1/STOP2)
     *        +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
     *        + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
 
      F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
     *        LOG(SBOT1/SBOT2)
     *        +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
     *        - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
 
      F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
     *         (-.5D0*LOG(STOP12/STOP22)
     *        +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
     *         G(STOP12,STOP22))
 
      F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
     *         (.5D0*LOG(SBOT12/SBOT22)
     *        +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
     *        G(SBOT12,SBOT22))
 
      VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
     *  (MQ2+MBOT2)/(MD2+MBOT2))
     *  + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
     *  LOG(SBOT1**2/SBOT2**2)) +
     *  MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
     *  (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
 
      VH3T(1,1) =
     *  MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
     * -STOP2**2))**2*G(STOP12,STOP22)
 
      VH3B(1,1)=VH3B(1,1)+
     *    MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
 
      VH3T(1,1) = VH3T(1,1) +
     *  MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
 
      VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
     *  (MQ2+MTOP2)/(MUR2+MTOP2))
     *  + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
     *  LOG(STOP1**2/STOP2**2)) +
     *  MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
     *  (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
 
      VH3B(2,2) =
     *  MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
     * -SBOT2**2))**2*G(SBOT12,SBOT22)
 
      VH3T(2,2)=VH3T(2,2)+
     *    MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
      VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
      VH3T(1,2) = -
     *   MTOP4/(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) =
     * - MBOT4/(COSBB**2)*XMU*(AB-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) +
     *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
 
      VH3B(1,2)=VH3B(1,2) +
     *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
 
      VH3T(2,1) = VH3T(1,2)
      VH3B(2,1) = VH3B(1,2)
 
C      TQ = LOG((MQ2 + MTOP2)/MTOP2)
C      TU = LOG((MUR2+MTOP2)/MTOP2)
C      TQD = LOG((MQ2 + MB**2)/MB**2)
C      TD = LOG((MD2+MB**2)/MB**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) = -1D15
  130   CONTINUE
  140 CONTINUE
 
 
  150 RETURN
      END
 
 
 
 
 
C*********************************************************************
 
C...PYFINT
C...Auxiliary routine to PYPOLE 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
 
C...Local variables.
      COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
      COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
      INTEGER KFIN,KCIN
      DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
      DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
      DOUBLE PRECISION PYLAMF,XL
      DOUBLE PRECISION TANW,XW,AEM,C1,AS
      DOUBLE PRECISION AL,AR,BL,BR
      DOUBLE PRECISION CH1,CH2,CH3,CH4
      DOUBLE PRECISION XMBOT,XMTOP
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3)
      INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
      DOUBLE PRECISION SR2
      DOUBLE PRECISION CBETA,SBETA
      DOUBLE PRECISION CW
      DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
      DOUBLE PRECISION COSA,SINA,TANB
      DOUBLE PRECISION PYALEM,PI,PYALPS,EI
      DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
      INTEGER IG,KF1,KF2
      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)
      XW=PARU(102)
      TANW = SQRT(XW/(1D0-XW))
      CW=SQRT(1D0-XW)
 
      DO 110 I=1,4
        DO 100 J=1,4
          ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
  100   CONTINUE
  110 CONTINUE
      DO 130 I=1,2
        DO 120 J=1,2
           VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
           UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
  120   CONTINUE
  130 CONTINUE
 
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=PYMRUN(5,XMI2)
      XMTOP=PYMRUN(6,XMI2)
 
      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 140 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
            CBL=VMIXC(IX,1)
            CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
            CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
            CAR=0D0
          ELSE
            IF(IFL.EQ.5) THEN
              XMF =XMBOT
              XMFP=XMTOP
            ELSEIF(IFL.LT.5) THEN
              XMF=0D0
              XMFP=0D0
            ENDIF
            CBL=UMIXC(IX,1)
            CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
            CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
            CAR=0D0
          ENDIF
 
          CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
          CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
          CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
          CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
          CAL=CALP
          CBL=CBLP
          CAR=CARP
          CBR=CBRP
 
C...F1 -> F` CHI
          IF(ILR.EQ.1) THEN
            CA=CAL
            CB=CBL
C...F2 -> F` CHI
          ELSE
            CA=CAR
            CB=CBR
          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)*
     &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(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
  140 CONTINUE
 
C...NEUTRAL DECAYS
      DO 150 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
            CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
            CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
            CAR=-2D0*EI*TANW*ZMIXC(IX,1)
            CBR=CAL
          ELSE
            IF(IFL.EQ.6) THEN
              XMF=XMTOP
            ELSEIF(IFL.LT.5) THEN
              XMF=0D0
            ENDIF
            CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
            CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
            CAR=-2D0*EI*TANW*ZMIXC(IX,1)
            CBR=CAL
          ENDIF
 
          CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
          CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
          CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
          CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
          CAL=CALP
          CBL=CBLP
          CAR=CARP
          CBR=CBRP
 
C...F1 -> F CHI
          IF(ILR.EQ.1) THEN
            CA=CAL
            CB=CBL
C...F2 -> F CHI
          ELSE
            CA=CAR
            CB=CBR
          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)*
     &    (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
          IDLAM(LKNT,1)=KFNCHI(IX)
          IDLAM(LKNT,2)=IFL
          IDLAM(LKNT,3)=0
        ENDIF
  150 CONTINUE
 
C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
C...IG=23,25,35,36
      DO 160 II=1,4
        IG=IGG(II)
        IF(ILR.EQ.1) GOTO 160
        XMB=PMAS(IG,1)
        XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
        IF(XMI.LT.XMSF1+XMB) GOTO 160
        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
C.........need to complexify
          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
C.........Need to complexify
          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
C.........Need to complexify
          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
  160 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
C.......Need to complexify
        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
C.......Need to complexify
        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
            XCA=AL
            XCB=BL
C...F2 -> F CHI
          ELSE
            XCA=AR
            XCB=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)*
     &    (XCA**2+XCB**2)+4D0*XCA*XCB*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
 
C...R-violating sfermion decays (SKANDS).
      CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
 
      IKNT=LKNT
      XLAM(0)=0D0
      DO 170 I=1,IKNT
        IF(XLAM(I).LT.0D0) XLAM(I)=0D0
        XLAM(0)=XLAM(0)+XLAM(I)
  170 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
CC     &SFMIX(16,4),
C      COMMON/PYINTS/XXM(20)
      COMPLEX*16 CXC
      COMMON/PYINTC/XXC(10),CXC(8)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
 
C...Local variables
      COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
      DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
      DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
      DOUBLE PRECISION PYLAMF,XL
      DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
      DOUBLE PRECISION CA,CB,AL,AR,BL,BR
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3)
      INTEGER LKNT,IX,ILR,I,IKNT,IFL
      DOUBLE PRECISION SR2
      DOUBLE PRECISION GAM
      DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
      EXTERNAL PYGAUS,PYXXZ6
      DOUBLE PRECISION PYGAUS,PYXXZ6
      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)
 
      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=AXMI**3
 
      XMI=SIGN(XMI,RMSS(3))
 
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*AXMI/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)
          IF(AXMI.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 170 IX=1,4
        XMJ=SMZ(IX)
        AXMJ=ABS(XMJ)
        IF(AXMI.GE.AXMJ) THEN
          DO 120 I=1,4
            ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
  120     CONTINUE
          OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
          ORPP=DCONJG(OLPP)
          XXC(1)=0D0
          XXC(2)=XMJ
          XXC(3)=0D0
          XXC(4)=XMI
          IA=1
          XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
          XXC(9)=1D6
          XXC(10)=0D0
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
          GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
          CXC(1)=0D0
          CXC(2)=-GLIJ
          CXC(3)=0D0
          CXC(4)=DCONJG(GLIJ)
          CXC(5)=0D0
          CXC(6)=GRIJ
          CXC(7)=0D0
          CXC(8)=-DCONJG(GRIJ)
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
          IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
            IDLAM(LKNT,1)=KFNCHI(IX)
            IDLAM(LKNT,2)=1
            IDLAM(LKNT,3)=-1
          ENDIF
          IF(AXMI.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
  130     CONTINUE
          IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
            PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
            IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
              GOTO 140
            ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
              PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
            ENDIF
            CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
            LKNT=LKNT+1
            XLAM(LKNT)=GAM
            IDLAM(LKNT,1)=KFNCHI(IX)
            IDLAM(LKNT,2)=5
            IDLAM(LKNT,3)=-5
            PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
          ENDIF
C...U-TYPE QUARKS
  140     CONTINUE
          IA=2
          XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
C        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
          GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
          CXC(2)=-GLIJ
          CXC(4)=DCONJG(GLIJ)
          CXC(6)=GRIJ
          CXC(8)=-DCONJG(GRIJ)
          IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
          IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
            IDLAM(LKNT,1)=KFNCHI(IX)
            IDLAM(LKNT,2)=2
            IDLAM(LKNT,3)=-2
          ENDIF
          IF(AXMI.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
  150     CONTINUE
C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
          XMF=PMAS(6,1)
          IF(AXMI.GE.AXMJ+2D0*XMF) THEN
            PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
            IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
              GOTO 160
            ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
              PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
            ENDIF
            CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
            LKNT=LKNT+1
            XLAM(LKNT)=GAM
            IDLAM(LKNT,1)=KFNCHI(IX)
            IDLAM(LKNT,2)=6
            IDLAM(LKNT,3)=-6
            PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
          ENDIF
  160     CONTINUE
        ENDIF
  170 CONTINUE
 
C...GLUINO -> CI Q QBAR'
      DO 210 IX=1,2
        XMJ=SMW(IX)
        AXMJ=ABS(XMJ)
        IF(AXMI.GE.AXMJ) THEN
          DO 180 I=1,2
            VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
            UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
  180     CONTINUE
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          XXC(1)=0D0
          XXC(2)=XMJ
          XXC(3)=0D0
          XXC(4)=XMI
          XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
          XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
          XXC(9)=1D6
          XXC(10)=0D0
          OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
          ORPP=DCONJG(OLPP)
          CXC(1)=DCMPLX(0D0,0D0)
          CXC(3)=DCMPLX(0D0,0D0)
          CXC(5)=DCMPLX(0D0,0D0)
          CXC(7)=DCMPLX(0D0,0D0)
          CXC(2)=UMIXC(IX,1)*OLPP/SR2
          CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
          CXC(6)=DCMPLX(0D0,0D0)
          CXC(8)=DCMPLX(0D0,0D0)
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ELSEIF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
          IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
          IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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(AXMI.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
  190     CONTINUE
 
          XMF=PMAS(6,1)
          XMFP=PMAS(5,1)
          IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
            IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
     $      PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
            PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
            PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
            PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
            PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
            IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
            IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
            IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
            IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
            CALL PYTBBC(IX,100,XMI,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)
            PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
            PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
            PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
            PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
          ENDIF
  200     CONTINUE
        ENDIF
  210 CONTINUE
 
C...R-parity violating (3-body) decays.
      CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
 
      IKNT=LKNT
      XLAM(0)=0D0
      DO 220 I=1,IKNT
        IF(XLAM(I).LT.0D0) XLAM(I)=0D0
        XLAM(0)=XLAM(0)+XLAM(I)
  220 CONTINUE
      IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
 
      RETURN
      END
 
 
C*********************************************************************
 
C...PYTBBN
C...Calculates the three-body decay of gluinos into
C...neutralinos and third generation fermions.
 
      SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      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
      DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
      SAVE HLT,HRT,FLT,FRT
      DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
      SAVE AMN,AN,ZN
      DOUBLE PRECISION AMBOT,SINC,COSC
      DOUBLE PRECISION AMTOP,SINA,COSA
      DOUBLE PRECISION SINW,COSW,TANW
      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=PYMRUN(5,XMGLU**2)
      AMTOP=PYMRUN(6,XMGLU**2)
      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
C          FLU(J)=ZN(3)
C          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
C          FLD(J)=ZN(3)
C          FRD(J)=ZN(2)
  150   CONTINUE
C        AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
C        AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
C        AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
C        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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      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
      DOUBLE PRECISION AMC(2)
      SAVE AMC
      DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
      DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
      SAVE AMSB,AMST
      LOGICAL IFIRST
      SAVE IFIRST
      DATA IFIRST/.TRUE./
 
      TANB=RMSS(5)
      SINB=TANB/SQRT(1D0+TANB**2)
      COSB=SINB/TANB
      XW=PARU(102)
      AMW=PMAS(24,1)
      COSC=SFMIX(5,1)
      SINC=SFMIX(5,3)
      COSA=SFMIX(6,1)
      SINA=SFMIX(6,3)
      AMBOT=PYMRUN(5,XMGLU**2)
      AMTOP=PYMRUN(6,XMGLU**2)
      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
 
      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=PMAS(6,1)
      XMB=PMAS(5,1)
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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)
c      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
c     &SFMIX(16,4)
      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
     &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C      COMMON/PYINTS/XXM(20)
      COMPLEX*16 CXC
      COMMON/PYINTC/XXC(10),CXC(8)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
 
C...Local variables.
      COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
      COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
      INTEGER KFIN
      DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
     &XMZ,XMZ2,AXMJ,AXMI
      DOUBLE PRECISION S12MIN,S12MAX
      DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
      DOUBLE PRECISION PYLAMF,XL
      DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
      DOUBLE PRECISION PYX2XH,PYX2XG
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3)
      INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
      INTEGER ITH(3),KF1,KF2
      INTEGER ITHC
      DOUBLE PRECISION DH(3),EH(3)
      DOUBLE PRECISION SR2
      DOUBLE PRECISION CBETA,SBETA
      DOUBLE PRECISION GAMCON,XMT1,XMT2
      DOUBLE PRECISION PYALEM,PI,PYALPS
      DOUBLE PRECISION RAT1,RAT2
      DOUBLE PRECISION T3T,FCOL
      DOUBLE PRECISION ALFA,BETA,TANB
      DOUBLE PRECISION PYXXGA
      EXTERNAL PYGAUS,PYXXZ6
      DOUBLE PRECISION PYGAUS,PYXXZ6
      DOUBLE PRECISION PREC
      INTEGER KFNCHI(4),KFCCHI(2)
      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
      XW1=1D0-XW
      TANW = SQRT(XW/XW1)
 
C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
      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)
 
      DO 110 I=1,4
        DO 100 J=1,4
          ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
  100   CONTINUE
  110 CONTINUE
      DO 130 I=1,2
        DO 120 J=1,2
           VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
           UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
  120   CONTINUE
  130 CONTINUE
 
C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
      IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
 
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 340
      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*ABS(ZMIXC(IX,1)*COSW+ZMIXC(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*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
     $  .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(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*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(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*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(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*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
     $  .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
        ENDIF
        IF(IX.EQ.1) GOTO 300
      ENDIF
 
      DO 220 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=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
          RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
          RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
          RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(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
          OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
     &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
          ORPP=-DCONJG(OLPP)
          GX2=ABS(OLPP)**2+ABS(ORPP)**2
          GLR=DBLE(OLPP*DCONJG(ORPP))
          XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
          IDLAM(LKNT,1)=KFNCHI(IJ)
          IDLAM(LKNT,2)=23
          IDLAM(LKNT,3)=0
        ELSEIF(AXMI.GE.AXMJ) THEN
          XXC(1)=0D0
          XXC(2)=XMJ
          XXC(3)=0D0
          XXC(4)=XMI
          XXC(9)=XMZ
          XXC(10)=PMAS(23,2)
          OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
     &    ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
          ORPP=DCONJG(OLPP)
C...CHARGED LEPTONS
          FID=11
          XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
          EI=KCHG(FID,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
     &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
          GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
          CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
          CXC(2)=-GLIJ
          CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
          CXC(4)=DCONJG(GLIJ)
          CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
          CXC(6)=GRIJ
          CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
          CXC(8)=-DCONJG(GRIJ)
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          IF(XXC(6).LT.AXMI ) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
 
          IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
            IDLAM(LKNT,1)=KFNCHI(IJ)
            IDLAM(LKNT,2)=FID
            IDLAM(LKNT,3)=-FID
            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
  140     CONTINUE
          IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
            XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
          ELSE
            XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
            XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
          ENDIF
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          IF(XXC(6).LT.AXMI ) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
 
          IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
            IDLAM(LKNT,1)=KFNCHI(IJ)
            IDLAM(LKNT,2)=15
            IDLAM(LKNT,3)=-15
          ENDIF
 
C...NEUTRINOS
  150     CONTINUE
          FID=12
          XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
          EI=KCHG(FID,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
     &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
          GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
          CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
          CXC(2)=-GLIJ
          CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
          CXC(4)=DCONJG(GLIJ)
          CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
          CXC(6)=GRIJ
          CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
          CXC(8)=-DCONJG(GRIJ)
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          IF( XXC(6).LT.AXMI ) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
 
          LKNT=LKNT+1
          XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
  160     CONTINUE
 
          IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
     &    THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
            IF( XXC(5).LT.AXMI ) THEN
              XXC(5)=1D6
            ENDIF
            XXC(7)=XXC(5)
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
          ELSE
            LKNT=LKNT+1
            XLAM(LKNT)=XLAM(LKNT-1)
          ENDIF
          IDLAM(LKNT,1)=KFNCHI(IJ)
          IDLAM(LKNT,2)=16
          IDLAM(LKNT,3)=-16
C...D-TYPE QUARKS
  170     CONTINUE
          FID=1
          XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
          EI=KCHG(FID,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
     &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
          GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
          CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
          CXC(2)=-GLIJ
          CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
          CXC(4)=DCONJG(GLIJ)
          CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
          CXC(6)=GRIJ
          CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
          CXC(8)=-DCONJG(GRIJ)
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          IF( XXC(6).LT.AXMI ) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
 
          IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  180     CONTINUE
          IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
            XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
          ELSE
            XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
            XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
          ENDIF
          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ELSEIF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
          IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
            IDLAM(LKNT,1)=KFNCHI(IJ)
            IDLAM(LKNT,2)=5
            IDLAM(LKNT,3)=-5
          ENDIF
 
C...U-TYPE QUARKS
  190     CONTINUE
          FID=2
          XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
          EI=KCHG(FID,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
     &    DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
          GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
          CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
          CXC(2)=-GLIJ
          CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
          CXC(4)=DCONJG(GLIJ)
          CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
          CXC(6)=GRIJ
          CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
          CXC(8)=-DCONJG(GRIJ)
 
          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ELSEIF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(5)
          XXC(8)=XXC(6)
 
          IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  200     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=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
     &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
     &  TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
     &  DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
        RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
     &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
     &  TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
     &  ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
        DO 210 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
            GX2=ABS(F21K)**2+ABS(F12K)**2
            GLR=DBLE(F21K*DCONJG(F12K))
            XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
            IDLAM(LKNT,1)=KFNCHI(IJ)
            IDLAM(LKNT,2)=ITH(IH)
            IDLAM(LKNT,3)=0
          ENDIF
  210   CONTINUE
  220 CONTINUE
 
C...CHI0_I -> CHI+_J + W-
      DO 260 IJ=1,2
        XMJ=SMW(IJ)
        AXMJ=ABS(XMJ)
        XMJ2=XMJ**2
        IF(AXMI.GE.AXMJ+XMW) THEN
          LKNT=LKNT+1
          CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
     &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
          CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
     &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
          GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
          GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
          XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
          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
          RT2I = 1D0/SQRT(2D0)
          CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
     &    DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
          CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
     &    ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
          CXC(5)=DCMPLX(0D0,0D0)
          CXC(7)=DCMPLX(0D0,0D0)
          IA=11
          JA=12
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          EJ=KCHG(JA,1)/3D0
          T3J=SIGN(1D0,EJ+1D-6)/2D0
          CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
     &    TANW+ZMIXC(IX,2)*T3J)*RT2I
          CXC(4)=-DCONJG(UMIXC(IJ,1))*(
     &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
          CXC(6)=DCMPLX(0D0,0D0)
          CXC(8)=DCMPLX(0D0,0D0)
          XXC(1)=0D0
          XXC(2)=XMJ
          XXC(3)=0D0
          XXC(4)=XMI
          XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
          XXC(9)=PMAS(24,1)
          XXC(10)=PMAS(24,2)
          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ELSEIF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
          IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  230     CONTINUE
          IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
            XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
          ELSE
            XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
            XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
          ENDIF
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ENDIF
          IF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
          IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  240     CONTINUE
          IA=1
          JA=2
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          EJ=KCHG(JA,1)/3D0
          T3J=SIGN(1D0,EJ+1D-6)/2D0
          CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
     &    TANW+ZMIXC(IX,2)*T3J)
          CXC(4)=-DCONJG(UMIXC(IJ,1))*(
     &    ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
          XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ENDIF
          IF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
          IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  250     CONTINUE
        ENDIF
  260 CONTINUE
  270 CONTINUE
 
C...CHI0_I -> CHI+_I + H-
      DO 280 IJ=1,2
        XMJ=SMW(IJ)
        AXMJ=ABS(XMJ)
        XMJ2=XMJ**2
        XMHP=PMAS(ITHC,1)
        IF(AXMI.GE.AXMJ+XMHP) THEN
          LKNT=LKNT+1
          OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
     &    ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
          ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
     &    (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
     &    UMIXC(IJ,2)/SR2)
          GX2=ABS(OLPP)**2+ABS(ORPP)**2
          GLR=DBLE(OLPP*DCONJG(ORPP))
          XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
          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
  280 CONTINUE
 
C...2-BODY DECAYS TO FERMION SFERMION
      DO 290 J=1,16
        IF(J.GE.7.AND.J.LE.10) GOTO 290
        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
          CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
          CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
          CAR=-2D0*EI*TANW*ZMIXC(IX,1)
          CBR=CAL
        ELSE
          CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
          CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
          CAR=-2D0*EI*TANW*ZMIXC(IX,1)
          CBR=CAL
        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=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
          CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
          XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
     &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(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=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
          CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
          XL=PYLAMF(XMI2,XMA2,XMB2)
          XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
     &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(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
  290 CONTINUE
  300 CONTINUE
C...3-BODY DECAY TO Q Q~ GLUINO
      XMJ=PMAS(PYCOMP(KSUSY1+21),1)
      IF(AXMI.GE.XMJ) THEN
        RT2I = 1D0/SQRT(2D0)
        OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
        ORPP=DCONJG(OLPP)
        AXMJ=ABS(XMJ)
        XXC(1)=0D0
        XXC(2)=XMJ
        XXC(3)=0D0
        XXC(4)=XMI
        FID=1
        XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
        XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        XXC(9)=1D6
        XXC(10)=0D0
        EI=KCHG(FID,1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
        GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
        CXC(1)=0D0
        CXC(2)=-GLIJ
        CXC(3)=0D0
        CXC(4)=DCONJG(GLIJ)
        CXC(5)=0D0
        CXC(6)=GRIJ
        CXC(7)=0D0
        CXC(8)=-DCONJG(GRIJ)
        S12MIN=0D0
        S12MAX=(AXMI-AXMJ)**2
CMRENNA.This statement must be here to define S12MAX
        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
C...ALL QUARKS BUT T
        IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
  310   CONTINUE
        IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
          XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
          XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
        ELSE
          XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
          XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
        ENDIF
        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
          IDLAM(LKNT,1)=KSUSY1+21
          IDLAM(LKNT,2)=5
          IDLAM(LKNT,3)=-5
        ENDIF
C...U-TYPE QUARKS
  320   CONTINUE
        FID=2
        XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
        XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        EI=KCHG(FID,1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
        GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
        CXC(2)=-GLIJ
        CXC(4)=DCONJG(GLIJ)
        CXC(6)=GRIJ
        CXC(8)=-DCONJG(GRIJ)
        IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
  330   CONTINUE
      ENDIF
 
C...R-violating decay modes (SKANDS).
      CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
 
  340 IKNT=LKNT
      XLAM(0)=0D0
      DO 350 I=1,IKNT
        IF(XLAM(I).LT.0D0) XLAM(I)=0D0
        XLAM(0)=XLAM(0)+XLAM(I)
  350 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
CC     &SFMIX(16,4),
C      COMMON/PYINTS/XXM(20)
      COMPLEX*16 CXC
      COMMON/PYINTC/XXC(10),CXC(8)
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
 
C...Local variables
      COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
      COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
      INTEGER KFIN,KCIN
      DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
     &XMZ,XMZ2,AXMJ,AXMI
      DOUBLE PRECISION S12MIN,S12MAX
      DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
      DOUBLE PRECISION PYLAMF,XL
      DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
      DOUBLE PRECISION PYX2XH,PYX2XG
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3)
      INTEGER LKNT,IX,IH,J,IJ,I,IKNT
      INTEGER ITH(3)
      INTEGER ITHC
      DOUBLE PRECISION ETAH(3),DH(3),EH(3)
      DOUBLE PRECISION SR2
      DOUBLE PRECISION CBETA,SBETA,TANB
 
      DOUBLE PRECISION PYALEM,PI,PYALPS
      DOUBLE PRECISION FCOL
      INTEGER KF1,KF2,ISF
      INTEGER KFNCHI(4),KFCCHI(2)
 
      DOUBLE PRECISION TEMP
      EXTERNAL PYGAUS,PYXXZ6
      DOUBLE PRECISION PYGAUS,PYXXZ6
      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
      XW1=1D0-XW
      TANW = SQRT(XW/XW1)
 
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)
 
      DO 110 I=1,2
        DO 100 J=1,2
          VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
          UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
  100   CONTINUE
  110 CONTINUE
 
C...GRAVITINO DECAY MODES
 
      IF(IMSS(11).EQ.1) THEN
        XMP=RMSS(29)
        IDG=39+KSUSY1
        XMGR=PMAS(PYCOMP(IDG),1)
C        SINW=SQRT(XW)
C        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*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
     &  .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(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*((ABS(VMIXC(IX,2))*CBETA)**2+
     &   (ABS(UMIXC(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 170
      XMJ=SMW(1)
      AXMJ=ABS(XMJ)
      XMJ2=XMJ**2
 
C...CHI_2+ -> CHI_1+ + Z0
      IF(AXMI.GE.AXMJ+XMZ) THEN
        LKNT=LKNT+1
        IJ=1
        OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
     &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
        ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
     &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
        GX2=ABS(OLPP)**2+ABS(ORPP)**2
        GLR=DBLE(OLPP*DCONJG(ORPP))
        XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
        IDLAM(LKNT,1)=KFCCHI(1)
        IDLAM(LKNT,2)=23
        IDLAM(LKNT,3)=0
 
C...CHARGED LEPTONS
      ELSEIF(AXMI.GE.AXMJ) THEN
        S12MIN=0D0
        S12MAX=(AXMI-AXMJ)**2
        IA=11
        JA=12
        EI=KCHG(IABS(IA),1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        XXC(1)=0D0
        XXC(2)=XMJ
        XXC(3)=0D0
        XXC(4)=XMI
        XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
        XXC(6)=1D6
        XXC(9)=PMAS(23,1)
        XXC(10)=PMAS(23,2)
        IJ=1
        OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
     &  VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
        ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
     &  UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
        CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
        CXC(2)=DCMPLX(0D0,0D0)
        CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
        CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
        CXC(5)=-DCMPLX(EI/XW1)*ORPP
        CXC(6)=DCMPLX(0D0,0D0)
        CXC(7)=-DCMPLX(EI/XW1)*OLPP
        CXC(8)=DCMPLX(0D0,0D0)
        IF( XXC(5).LT.AXMI ) THEN
          XXC(5)=1D6
        ENDIF
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
          ENDIF
          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
 
C...NEUTRINOS
  120   CONTINUE
        IA=12
        JA=11
        EI=KCHG(IABS(IA),1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
        XXC(6)=1D6
        CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
        CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
        CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
        CXC(5)=-DCMPLX(EI/XW1)*ORPP
        CXC(7)=-DCMPLX(EI/XW1)*OLPP
        IF( XXC(5).LT.AXMI ) THEN
          XXC(5)=1D6
        ENDIF
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
        ENDIF
        IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
          IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
          ELSE
            XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
          ENDIF
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          XXC(7)=XXC(5)
          LKNT=LKNT+1
          XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
          IDLAM(LKNT,1)=KFCCHI(1)
          IDLAM(LKNT,2)=16
          IDLAM(LKNT,3)=-16
        ENDIF
 
C...D-TYPE QUARKS
  130   CONTINUE
        IA=1
        JA=2
        EI=KCHG(IABS(IA),1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
        XXC(6)=1D6
        CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
        CXC(2)=DCMPLX(0D0,0D0)
        CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
        CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
        CXC(5)=-DCMPLX(EI/XW1)*ORPP
        CXC(6)=DCMPLX(0D0,0D0)
        CXC(7)=-DCMPLX(EI/XW1)*OLPP
        CXC(8)=DCMPLX(0D0,0D0)
        IF( XXC(5).LT.AXMI ) THEN
          XXC(5)=1D6
        ENDIF
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
          ENDIF
        ENDIF
        IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
          IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
            XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
          ELSE
            XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
          ENDIF
          IF( XXC(5).LT.AXMI ) THEN
            XXC(5)=1D6
          ENDIF
          XXC(7)=XXC(5)
          LKNT=LKNT+1
          XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
          IDLAM(LKNT,1)=KFCCHI(1)
          IDLAM(LKNT,2)=5
          IDLAM(LKNT,3)=-5
        ENDIF
 
C...U-TYPE QUARKS
  140   CONTINUE
        IA=2
        JA=1
        EI=KCHG(IABS(IA),1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
        XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
        XXC(6)=1D6
        CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
        CXC(2)=DCMPLX(0D0,0D0)
        CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
        CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
        CXC(5)=-DCMPLX(EI/XW1)*ORPP
        CXC(6)=DCMPLX(0D0,0D0)
        CXC(7)=-DCMPLX(EI/XW1)*OLPP
        CXC(8)=DCMPLX(0D0,0D0)
        IF( XXC(5).LT.AXMI ) THEN
          XXC(5)=1D6
        ENDIF
        XXC(7)=XXC(5)
        XXC(8)=XXC(6)
        IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
  150   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 160 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)
          OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
     &    VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
          ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
     &    DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
          XMK=XMJ*ETAH(IH)
          GX2=ABS(OLPP)**2+ABS(ORPP)**2
          GLR=DBLE(OLPP*DCONJG(ORPP))
          XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
          IDLAM(LKNT,1)=KFCCHI(1)
          IDLAM(LKNT,2)=ITH(IH)
          IDLAM(LKNT,3)=0
        ENDIF
  160 CONTINUE
 
C...CHI1 JUMPS TO HERE
  170 CONTINUE
 
C...CHI+_I -> CHI0_J + W+
      DO 220 IJ=1,4
        XMJ=SMZ(IJ)
        AXMJ=ABS(XMJ)
        XMJ2=XMJ**2
        IF(AXMI.GE.AXMJ+XMW) THEN
          LKNT=LKNT+1
          DO 180 I=1,4
            ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
  180     CONTINUE
          CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
     &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
          CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
     &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
          GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
          GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
          XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
          IDLAM(LKNT,1)=KFNCHI(IJ)
          IDLAM(LKNT,2)=24
          IDLAM(LKNT,3)=0
C...LEPTONS
        ELSEIF(AXMI.GE.AXMJ) THEN
          S12MIN=0D0
          S12MAX=(AXMI-AXMJ)**2
          DO 190 I=1,4
            ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
  190     CONTINUE
          CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
     &    DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
          CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
     &    ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
          CXC(5)=DCMPLX(0D0,0D0)
          CXC(7)=DCMPLX(0D0,0D0)
          IA=11
          JA=12
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          EJ=KCHG(JA,1)/3D0
          T3J=SIGN(1D0,EJ+1D-6)/2D0
          CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
     &    TANW+ZMIXC(IJ,2)*T3J)/SR2
          CXC(4)=-DCONJG(UMIXC(IX,1))*(
     &    ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
          CXC(6)=DCMPLX(0D0,0D0)
          CXC(8)=DCMPLX(0D0,0D0)
          XXC(1)=0D0
          XXC(2)=XMJ
          XXC(3)=0D0
          XXC(4)=XMI
          XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
          XXC(9)=PMAS(24,1)
          XXC(10)=PMAS(24,2)
CCC          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ELSEIF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
C...--> 1/(16PI)/M**3*(AEM/XW)**2
          IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
            LKNT=LKNT+1
            TEMP=PYGAUS(PYXXZ6,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 260
            IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
              LKNT=LKNT+1
              XLAM(LKNT)=XLAM(LKNT-1)
              IDLAM(LKNT,1)=KFNCHI(IJ)
              IDLAM(LKNT,2)=-13
              IDLAM(LKNT,3)=14
            ENDIF
          ENDIF
          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
              XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
            ELSE
              XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
            ENDIF
            XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
            IF(XXC(5).LT.AXMI) THEN
              XXC(5)=1D6
            ELSEIF(XXC(6).LT.AXMI) THEN
              XXC(6)=1D6
            ENDIF
            XXC(7)=XXC(6)
            XXC(8)=XXC(5)
            TEMP=PYGAUS(PYXXZ6,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
 
C...NOW, DO THE QUARKS
  200     CONTINUE
          IA=1
          JA=2
          EI=KCHG(IA,1)/3D0
          T3I=SIGN(1D0,EI+1D-6)/2D0
          EJ=KCHG(JA,1)/3D0
          T3J=SIGN(1D0,EJ+1D-6)/2D0
          CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
     &    TANW+ZMIXC(IJ,2)*T3J)
          CXC(4)=-DCONJG(UMIXC(IX,1))*(
     &    ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
          XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
          XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
          IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
          IF(XXC(5).LT.AXMI) THEN
            XXC(5)=1D6
          ENDIF
          IF(XXC(6).LT.AXMI) THEN
            XXC(6)=1D6
          ENDIF
          XXC(7)=XXC(6)
          XXC(8)=XXC(5)
          IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
            LKNT=LKNT+1
            XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
     &      PYGAUS(PYXXZ6,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
  210     CONTINUE
        ENDIF
  220 CONTINUE
 
C...CHI+_I -> CHI0_J + H+
      DO 230 IJ=1,4
        XMJ=SMZ(IJ)
        AXMJ=ABS(XMJ)
        XMJ2=XMJ**2
        XMHP=PMAS(ITHC,1)
        IF(AXMI.GE.AXMJ+XMHP) THEN
          LKNT=LKNT+1
          OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
     &    ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
          ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
     &    (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
     &    UMIXC(IX,2)/SR2)
          GX2=ABS(OLPP)**2+ABS(ORPP)**2
          GLR=DBLE(OLPP*DCONJG(ORPP))
          XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
          IDLAM(LKNT,1)=KFNCHI(IJ)
          IDLAM(LKNT,2)=ITHC
          IDLAM(LKNT,3)=0
        ELSE
 
        ENDIF
  230 CONTINUE
 
C...2-BODY DECAYS TO FERMION SFERMION
      DO 240 J=1,16
        IF(J.GE.7.AND.J.LE.10) GOTO 240
        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)
          CAL=UMIXC(IX,1)
          CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
          CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
          CBR=0D0
          ISF=J-1
        ELSE
          XMFP=PMAS(J+1,1)
          CAL=VMIXC(IX,1)
          CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
          CBR=0D0
          CAR=-XMFP*VMIXC(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=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
          CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
          XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
     &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(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=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
          CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
          XL=PYLAMF(XMI2,XMA2,XMB2)
          XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
     &    (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(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
  240 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
        XXC(1)=0D0
        XXC(2)=XMJ
        XXC(3)=0D0
        XXC(4)=XMI
        XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
        XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
        XXC(9)=1D6
        XXC(10)=0D0
        OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
        ORPP=DCONJG(OLPP)
        CXC(1)=DCMPLX(0D0,0D0)
        CXC(3)=DCMPLX(0D0,0D0)
        CXC(5)=DCMPLX(0D0,0D0)
        CXC(7)=DCMPLX(0D0,0D0)
        CXC(2)=UMIXC(IX,1)*OLPP/SR2
        CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
        CXC(6)=DCMPLX(0D0,0D0)
        CXC(8)=DCMPLX(0D0,0D0)
        IF(XXC(5).LT.AXMI) THEN
          XXC(5)=1D6
        ELSEIF(XXC(6).LT.AXMI) THEN
          XXC(6)=1D6
        ENDIF
        XXC(7)=XXC(6)
        XXC(8)=XXC(5)
        IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
        IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
          LKNT=LKNT+1
          XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
     &    PYGAUS(PYXXZ6,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
  250   CONTINUE
      ENDIF
 
C...R-violating decay modes (SKANDS).
      CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
 
  260 IKNT=LKNT
      XLAM(0)=0D0
      DO 270 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
  270 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...PYXXZ6
C...Used in the calculation of  inoi -> inoj + f + ~f.
 
      FUNCTION PYXXZ6(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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
C      COMMON/PYINTS/XXM(20)
      COMPLEX*16 CXC
      COMMON/PYINTC/XXC(10),CXC(8)
      SAVE /PYDAT1/,/PYINTC/
 
C...Local variables.
      COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
      DOUBLE PRECISION PYXXZ6,X
      DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
      DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
      DOUBLE PRECISION SIJ
      DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
      DOUBLE PRECISION OL2
      DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
      INTEGER I
 
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=XXC(1)**2
      XM22=XXC(2)**2
      XM32=XXC(3)**2
      S=XXC(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)
 
      XMSD1=XXC(5)**2
      XMSD2=XXC(7)**2
      XMSU1=XXC(6)**2
      XMSU2=XXC(8)**2
 
      XMV=XXC(9)
      XMG=XXC(10)
      QLLS=CXC(1)
      QLLU=CXC(2)
      QLRS=CXC(3)
      QLRT=CXC(4)
      QRLS=CXC(5)
      QRLT=CXC(6)
      QRRS=CXC(7)
      QRRU=CXC(8)
      WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
      SIJ=2D0*XXC(2)*XXC(4)*S13
      IF(XMV.LE.1000D0) THEN
        OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
        OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
        WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
     &  +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
        IF(XXC(5).LE.10000D0) THEN
          WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
     &    TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
     &    .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
     &    DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
     &    .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
     &    *(S13-XMV**2)/WPROP2
        ELSE
          WFL1=0D0
        ENDIF
 
        IF(XXC(6).LE.10000D0) THEN
          WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
     &    TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
     &    .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
     &    DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
     &    .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
     &    *(S13-XMV**2)/WPROP2
        ELSE
          WFL2=0D0
        ENDIF
      ELSE
        WW=0D0
        WFL1=0D0
        WFL2=0D0
      ENDIF
      IF(XXC(5).LE.10000D0) THEN
        WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
     &  +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
     &  - 2D0*DBLE(QLRT*DCONJG(QLLU))*
     &  SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
      ELSE
        WF1=0D0
      ENDIF
      IF(XXC(6).LE.10000D0) THEN
        WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
     &  +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
     &  - 2D0*DBLE(QRLT*DCONJG(QRRU))*
     &  SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
      ELSE
        WF2=0D0
      ENDIF
 
      PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
 
      IF(PYXXZ6.LT.0D0) THEN
        WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
        WRITE(MSTU(11),*) (XXC(I),I=1,5)
        WRITE(MSTU(11),*) (XXC(I),I=6,10)
        WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
        WRITE(MSTU(11),*) S23MIN,S23MAX
        PYXXZ6=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,GX2,GLR)
 
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,GX2,GLR
      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)
     &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
     &12D0*GLR*XM1*XM2*XMV2)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYX2XH
C...Calculates the decay rate for ino -> ino + H.
 
      FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
 
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
      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)
     &*(GX2*(XMI2+XMJ2-XMV2)+
     &4D0*GLR*XM1*XM2)
 
      RETURN
      END
 
C*********************************************************************
 
C...PYHEXT
C...Calculates the non-standard decay modes of the Higgs boson.
C...
C...Author:  Stephen Mrenna
C...Last Update:  April 2001
C......Allow complex values for Z,U, and V
 
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
 
C...Local variables.
      COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
      COMPLEX*16 QIJ,RIJ,F21K,F12K
      INTEGER KFIN
      DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
      DOUBLE PRECISION XMI2,XMI3,XMJ2
      DOUBLE PRECISION PYLAMF,XL,CF,EI
      INTEGER IDU,IFL
      DOUBLE PRECISION TANW,XW,AEM,C1,AS
      DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3)
      INTEGER LKNT,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,TANB
      DOUBLE PRECISION PYALEM
      DOUBLE PRECISION AL,AR,ALR
      DOUBLE PRECISION XMK,AXMK,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 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)
      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)
      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)
 
      DO 110 I=1,4
        DO 100 J=1,4
          ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
  100   CONTINUE
  110 CONTINUE
      DO 130 I=1,2
        DO 120 J=1,2
           VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
           UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
  120   CONTINUE
  130 CONTINUE
 
 
      IF(IH.EQ.4) GOTO 220
 
C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
C...H0_K -> CHI0_I + CHI0_J
      EH(2)=SINA
      EH(1)=COSA
      EH(3)=CBETA
      DH(2)=COSA
      DH(1)=-SINA
      DH(3)=SBETA
      DO 150 IJ=1,4
        XMJ=SMZ(IJ)
        AXMJ=ABS(XMJ)
        DO 140 IK=1,IJ
          XMK=SMZ(IK)
          AXMK=ABS(XMK)
          IF(AXMI.GE.AXMJ+AXMK) THEN
            LKNT=LKNT+1
            QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
     &      ZMIXC(IJ,3)*ZMIXC(IK,2)-
     &      TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
     &      ZMIXC(IJ,3)*ZMIXC(IK,1))
            RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
     &      ZMIXC(IJ,4)*ZMIXC(IK,2)-
     &      TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
     &      ZMIXC(IJ,4)*ZMIXC(IK,1))
            F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
            F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
C...SIGN OF MASSES I,J
            XML=XMK*ETAH(IH)
            GX2=ABS(F12K)**2+ABS(F21K)**2
            GLR=DBLE(F12K*DCONJG(F21K))
            XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
            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
  140   CONTINUE
  150 CONTINUE
 
C...H0_K -> CHI+_I CHI-_J
      DO 170 IJ=1,2
        XMJ=SMW(IJ)
        AXMJ=ABS(XMJ)
        DO 160 IK=1,2
          XMK=SMW(IK)
          AXMK=ABS(XMK)
          IF(AXMI.GE.AXMJ+AXMK) THEN
            LKNT=LKNT+1
            OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
     &      VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
            ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
     &      VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
            GX2=ABS(OLPP)**2+ABS(ORPP)**2
            GLR=DBLE(OLPP*DCONJG(ORPP))
            XML=XMK*ETAH(IH)
            XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
            IDLAM(LKNT,1)=KFCCHI(IJ)
            IDLAM(LKNT,2)=-KFCCHI(IK)
            IDLAM(LKNT,3)=0
          ENDIF
  160   CONTINUE
  170 CONTINUE
 
C...HIGGS TO SFERMION SFERMION
      DO 200 IFL=1,16
        IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
        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 180
 
          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
  180     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
  190   CONTINUE
  200 CONTINUE
  210 CONTINUE
 
      GOTO 270
  220 CONTINUE
 
C...H+ -> CHI+_I + CHI0_J
      DO 240 IJ=1,4
        XMJ=SMZ(IJ)
        AXMJ=ABS(XMJ)
        XMJ2=XMJ**2
        DO 230 IK=1,2
          XMK=SMW(IK)
          AXMK=ABS(XMK)
          IF(AXMI.GE.AXMJ+AXMK) THEN
            LKNT=LKNT+1
            OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
     &      ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
            ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
     &      (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
            GX2=ABS(OLPP)**2+ABS(ORPP)**2
            GLR=DBLE(OLPP*DCONJG(ORPP))
            XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
            IDLAM(LKNT,1)=KFNCHI(IJ)
            IDLAM(LKNT,2)=KFCCHI(IK)
            IDLAM(LKNT,3)=0
          ENDIF
  230   CONTINUE
  240 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 250 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
  250 CONTINUE
 
C...H+ -> EL~ NUL
      CF=1D0
      DO 260 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
  260 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
 
  270 CONTINUE
      IKNT=LKNT
      XLAM(0)=0D0
      DO 280 I=1,IKNT
        IF(XLAM(I).LE.0D0) XLAM(I)=0D0
        XLAM(0)=XLAM(0)+XLAM(I)
  280 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,GX2,GLR)
 
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)
     &*(GX2*(XMI2-XMJ2-XMK2)-
     &4D0*GLR*XM3*XM2)
      IF(PYH2XX.LT.0D0) PYH2XX=0D0
 
      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) GOTO 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) GOTO 100
      ELSE
        BB = C1
        IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
        H = 0D0
        CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
        GOTO 140
      ENDIF
  140 CONTINUE
      PYGAUS = H
 
      RETURN
      END
 
C*********************************************************************
 
C...PYGAU2
C...Integration by adaptive Gaussian quadrature.
C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
C...Carbon copy of PYGAUS, but avoids having to use it recursively.
 
      FUNCTION PYGAU2(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) GOTO 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) GOTO 100
      ELSE
        BB = C1
        IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
        H = 0D0
        CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
        GOTO 140
      ENDIF
  140 CONTINUE
      PYGAU2 = 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(IDIN)
 
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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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)
C     COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
C     COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
     &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
C     SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
 
C...Local variables.
      DOUBLE PRECISION XM(5)
      COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
      COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
      COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
      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
      INTEGER INOID(4)
      DATA INOID/22,23,25,35/
      DATA EPS/1D-6/
 
      ID=IDIN
      ISKIP=1
      XM(1)=P(N+1,5)
      XM(2)=P(N+2,5)
      XM(3)=P(N+3,5)
      XM(5)=P(ID,5)
 
C...GENERATE S12
      S12MIN=(XM(1)+XM(2))**2
      S12MAX=(XM(5)-XM(3))**2
      YJACO1=S12MAX-S12MIN
 
C...Initialize some parameters
      XW=PARU(102)
      XW1=1D0-XW
      TANW=SQRT(XW/XW1)
      IZID1=0
      IWID1=0
      IZID2=0
      IWID2=0

      IA=K(N+2,2)
      JA=K(N+3,2)

C...Mrenna: check that we are indeed decaying a SUSY particle
      IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
      
      ELSE
        DO 100 I1=1,4
          IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
          IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
 100    CONTINUE
        IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
        IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
        IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
        IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
        ZM12=XM(5)**2
        ZM22=XM(1)**2
        EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
        T3I=SIGN(1D0,EI+1D-6)/2D0
      ENDIF

      IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
        ISKIP=0
      ELSEIF(IZID1*IZID2.NE.0) THEN
        SQMZ=PMAS(23,1)**2
        GMMZ=PMAS(23,1)*PMAS(23,2)
        DO 110 I=1,4
          ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
          ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
  110   CONTINUE
        OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
     &  ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
        ORPP=DCONJG(OLPP)
        XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
        XLR2=XLL2
        XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
        XRL2=XRR2
        GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
     &  DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
        GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
        XM1M2=SMZ(IZID1)*SMZ(IZID2)
        QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
        QLLU=-GLIJ
        QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
        QLRT=DCONJG(GLIJ)
        QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
        QRLT=GRIJ
        QRRS=DCMPLX((EI*XW)/XW1)*ORPP
        QRRU=-DCONJG(GRIJ)
      ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
        IF(IZID1.NE.0) THEN
          XM1M2=SMZ(IZID1)*SMW(IWID2)
          IZID1=IWID2
          IZID2=IZID1
        ELSE
          XM1M2=SMZ(IZID2)*SMW(IWID1)
          IZID1=IWID1
        ENDIF
        RT2I = 1D0/SQRT(2D0)
        SQMZ=PMAS(24,1)**2
        GMMZ=PMAS(24,1)*PMAS(24,2)
        DO 120 I=1,2
          VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
          UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
  120   CONTINUE
        DO 130 I=1,4
          ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
  130   CONTINUE
        QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
     &  DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
        QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
     &  ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
        EJ=KCHG(IABS(JA),1)/3D0
        T3J=SIGN(1D0,EJ+1D-6)/2D0
        QRLS=DCMPLX(0D0,0D0)
        QRLT=QRLS
        QRRS=QRLS
        QRRU=QRLS
        XRR2=1D6**2
        XRL2=XRR2
        XLR2  = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
        XLL2  = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
        IF(MOD(IA,2).EQ.0) THEN
          QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
     &    TANW+ZMIXC(IZID2,2)*T3I)
          QLRT=-DCONJG(UMIXC(IZID1,1))*(
     &    ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
        ELSE
          QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
     &    TANW+ZMIXC(IZID2,2)*T3J)
          QLRT=-DCONJG(UMIXC(IZID1,1))*(
     &    ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
        ENDIF
      ELSEIF(IWID1*IWID2.NE.0) THEN
        IZID1=IWID1
        IZID2=IWID2
        XM1M2=SMW(IWID1)*SMW(IWID2)
        SQMZ=PMAS(23,1)**2
        GMMZ=PMAS(23,1)*PMAS(23,2)
        DO 140 I=1,2
          VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
          UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
          VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
          UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
  140   CONTINUE
        OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
     &  VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
        ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
     &  UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
        QRLS=-DCMPLX(EI/XW1)*ORPP
        QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
        QRRS=-DCMPLX(EI/XW1)*OLPP
        QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
        IF(MOD(IA,2).EQ.0) THEN
          XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
          QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
        ELSE
          XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
          QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
        ENDIF
      ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
     &THEN
        ISKIP=0
      ELSE
        ISKIP=0
      ENDIF
 
      IF(ISKIP.NE.0) THEN
        WTMAX=0D0
        DO 160 KT=1,100
          S12=S12MIN+YJACO1*(KT-1)/99
          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(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
          S23DEL=S23DEL/EPS
          S23MIN=S23AVE-S23DEL
          S23MAX=S23AVE+S23DEL
          YJACO2=S23MAX-S23MIN
          TH=S12
          DO 150 KS=1,100
            S23=S23MIN+YJACO2*(KS-1)/99
            SH=S23
            UH=ZM12+ZM22-SH-TH
            WU2 = (UH-ZM12)*(UH-ZM22)
            WT2 = (TH-ZM12)*(TH-ZM22)
            WS2 = XM1M2*SH
            PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
            PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
            QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
            QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
            QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
            QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
            WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
     &      (ABS(QRL)**2+ABS(QLR)**2)*WT2+
     &      2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
            IF(WT0.GT.WTMAX) WTMAX=WT0
  150     CONTINUE
  160   CONTINUE
 
        WTMAX=WTMAX*1.05D0
      ENDIF
 
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(MAX(0D0,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(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
      F2=-2D0*S23DEL/EPS
 
  170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
        IF(F2.LE.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(MAX(0D0,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(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
          F1=-2D0*S23DEL/EPS
        ENDIF
        GOTO 170
      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
  180 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(MAX(0D0,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 190
      ENDIF
      IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
 
      IF(ISKIP.EQ.0) GOTO 190
 
      SH=S23
      TH=S12
      UH=ZM12+ZM22-SH-TH
 
      WU2 = (UH-ZM12)*(UH-ZM22)
      WT2 = (TH-ZM12)*(TH-ZM22)
      WS2 = XM1M2*SH
      PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
      PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
 
      QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
      QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
      QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
      QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
c      QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
c      QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
c     &/DCMPLX(TH-XML2)
c      QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
c      QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
c     &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
      WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
     &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
     &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
 
      IF(WT.LT.PYR(0)*WTMAX) GOTO 180
      IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
 
  190 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 200 I=1,3
        P(N+2,I)=-P(N+1,I)-P(N+3,I)
  200 CONTINUE
      P(N+2,4)=D2
 
      RETURN
      END
 
 
C*********************************************************************
 
C...PYTECM
C...Finds the s-hat dependent eigenvalues of the inverse propagator
C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
C...phase space generation.  Extended to include techni-a meson, and
C...to return the width.
 
      SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
 
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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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/PYTCSM/ITCM(0:99),RTCM(0:99)
      SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
 
C...Local variables.
      DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
     &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
     &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
      INTEGER i,j,ierr

      SH=SMIN
      SHR=SQRT(SH)
      AEM=PYALEM(SH)
 
      SINW=MIN(SQRT(PARU(102)),1D0)
      COSW=SQRT(1D0-SINW**2)
      TANW=SINW/COSW
      CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
      QUPD=2D0*RTCM(2)-1D0

      ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
      FAR=SQRT(AEM/ALPRHT)
      FAO=FAR*QUPD
      FZR=FAR*CT2W
      FZO=-FAO*TANW
      FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
      FWR=FAR/(2D0*SINW)
      FWX=-FWR/RTCM(47)

      DO 110 I=1,5
        DO 100 J=1,5
          AT(I,J)=0D0
  100   CONTINUE
  110 CONTINUE

C...NC
      IF(IOPT.EQ.1) THEN
        AR(1,1) = SH
        AR(2,2) = SH-PMAS(23,1)**2
        AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
        AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
        AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),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
        AR(2,5) = SH*FZX
        AR(5,2) = AR(2,5)
        AR(1,5) = 0D0
        AR(5,1) = AR(1,5)
        AR(3,5) = 0D0
        AR(5,3) = AR(3,5)
        AR(4,5) = 0D0
        AR(5,4) = AR(4,5)
        CALL PYWIDT(23,SH,WDTP,WDTE)
        AT(2,2) = WDTP(0)*SHR
        CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
        AT(3,3) = WDTP(0)*SHR
        CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
        AT(4,4) = WDTP(0)*SHR
        CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
        AT(5,5) = WDTP(0)*SHR
        IDIM=5
C...CC
      ELSE
        AR(1,1) = SH-PMAS(24,1)**2
        AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
        AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
        AR(1,2) = SH*FWR
        AR(2,1) = AR(1,2)
        AR(1,3) = SH*FWX
        AR(3,1) = AR(1,3)
        AR(2,3) = 0D0
        AR(3,2) = 0D0
        CALL PYWIDT(24,SH,WDTP,WDTE)
        AT(1,1) = WDTP(0)*SHR
        CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
        AT(2,2) = WDTP(0)*SHR
        CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
        AT(3,3) = WDTP(0)*SHR
        IDIM=3
      ENDIF
      CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)

      IMIN=1
      SXMN=1D20
      DO 120 I=1,IDIM
        WX(I)=SQRT(ABS(SH-WR(I)))
        WR(I)=ABS(WR(I))
        IF(WR(I).LT.SXMN) THEN
          SXMN=WR(I)
          IMIN=I
        ENDIF
  120 CONTINUE
      SMOU=WX(IMIN)**2
      WIDO=WI(IMIN)/SHR

      RETURN
      END
C*********************************************************************
 
C...PYXDIN
C...Universal Extra Dimensions Model (UED)
C...Initialize the xd masses and widths
C...M. ELKACIMI 4/03/2006
C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands

      SUBROUTINE PYXDIN

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(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
C...UED Pythia common
      COMMON/PYPUED/IUED(0:99),RUED(0:99)

C...SAVE statements
      SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/

C...Print out some info about the UED model
      WRITE(MSTU(11),7000) 
     &    ' ',
     &    '********** PYXDIN: initialization of UED ******************',
     &    ' ',
     &    'Universal Extra Dimensions (UED) switched on ',
     &    ' ',
     &    'This implementation is courtesy of',
     &    '       M.Elkacimi, D.Goujdami, H.Przysiezniak,  ', 
     &    '       see [hep-ph/0602198] (Les Houches 2005) ',
     &    ' ',
     &    'The model follows [hep-ph/0012100] (Appelquist, Cheng,   ',
     &    'Dobrescu), with gravity-mediated decay widths calculated in',
     &    '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
     &    'radiative corrections to the KK masses from [hep/ph0204342]',
     &    '(Cheng, Matchev, Schmaltz).'
      WRITE(MSTU(11),7000) 
     &    ' ',
     &    'SM particles can propagate into one small extra dimension  ',
     &    'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
     &    'graviton is further allowed to propagate into N = IUED(4)', 
     &    'large (eV^-1) extra dimensions.'
      WRITE(MSTU(11),7000) 
     &    ' ',
     &    'The switches and parameters for UED are:',
     &    '    IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
     &    '    IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
     &    '    IUED(3): (D=5) number of quark flavours',
     &    '    IUED(4): (D=6) number of large extra dimensions into',
     &    '                   which the graviton propagates',
     &    '    IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
     &    '    IUED(6): (D=1) With/without rad.corrs. (=1/0)',
     &    '                                                 ',
     &    '    RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
     &    '    RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
     &    '    RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
     &    '                        when IUED(5)=0',
     &    '    RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
      WRITE(MSTU(11),7000) 
     &    ' ',
     &    'N.B.: the Higgs mass is also a free parameter of the UED ',
     &    'model, but is set through pmas(25,1).',
     &    ' '

C...Hardcoded switch, required by current implementation     
      CALL PYGIVE('MSTP(42)=0')

C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
      IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')

C...Calculated the radiative corrections to the KK particle masses
      CALL PYUEDC

C...Initialize the graviton mass
C...only if the KK particles decays gravitationally
      IF(IUED(2).EQ.1) CALL PYGRAM(0)

      WRITE(MSTU(11),7000) 
     &    '********** PYXDIN: UED initialization completed  ***********'

C...Format to use for comments
 7000 FORMAT(' * ',A)

      RETURN
      END
C*********************************************************************
 
C...PYUEDC
C...Auxiliary to PYXDIN
C...Mass kk states radiative corrections 
C...Radiative corrections are included (hep/ph0204342)

      SUBROUTINE PYUEDC

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYK,PYCHGE,PYCOMP

      PARAMETER(KKPART=25,KKFLA=450)

C...UED Pythia common
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...Pythia common: particles properties
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)      
C...Parameters.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
C...Decay information.
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
C...Resonance width and secondary decay treatment.
      COMMON/PYINT4/MWID(500),WIDS(500,5)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)

C...Local variables
      DOUBLE PRECISION PI,QUP,QDW
      DOUBLE PRECISION WDTP,WDTE
      DIMENSION WDTP(0:400),WDTE(0:400,0:5)
      DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
      DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
      DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
      DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
      DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
      DOUBLE PRECISION SWW1,CWW1
      DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
      DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
      DOUBLE PRECISION SW21,CW21,SW021,CW021
      COMMON/SW1/SW021,CW021
C...UED related declarations:
C...equivalences between ordered particles (451->475)
C...and UED particle code (5 000 000 + id)
      DIMENSION IUEDEQ(475)
      DATA (IUEDEQ(I),I=451,475)/
C...Singlet quarks      
     & 6100001,6100002,6100003,6100004,6100005,6100006,
C...Doublet quarks
     & 5100001,5100002,5100003,5100004,5100005,5100006, 
C...Singlet leptons
     & 6100011,6100013,6100015,                         
C...Doublet leptons
     & 5100012,5100011,5100014,5100013,5100016,5100015,
C...Gauge boson KK excitations
     & 5100021,5100022,5100023,5100024/                 

C...N.B. rinv=rued(1)
      IF(RUED(1).LE.0.)THEN
         WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
         WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
         RETURN
      ENDIF

      PI=DACOS(-1.D0)
      RMZ  = PMAS(23,1)
      RMZ2 = RMZ**2
      RMW  = PMAS(24,1)
      RMW2 = RMW**2
      ALPHEM = PARU(101)
      QUP = 2./3.
      QDW = -1./3.

c...qt is q-tilde, qs is q-star
c...strong coupling value
      Q2 = RUED(1)**2
      ALPHS=PYALPS(Q2)
      
c...weak mixing angle
      SW2=PARU(102)
      CW2=1D0-PARU(102)
      
c...for the mass corrections
      RMKK = RUED(1)
      RMKK2 = RMKK**2
      ZETA3= 1.2
      
C... Either fix the cutoff scale LAMUED
      IF(IUED(5).EQ.0)THEN
         LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
C... or the ratio LAMUED/RINV (=product Lambda*R)
      ELSEIF(IUED(5).EQ.1)THEN
         LOGLAM = DLOG(RUED(4)**2)
      ELSE
         WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
         CALL PYSTOP(6000)
      ENDIF

C...Calculate the radiative corrections for the UED KK masses
      IF(IUED(6).EQ.1)THEN
         RFACT=1.D0
C...or induce a minute mass difference
C...keeping the UED KK mass values nearly equal to 1/R
      ELSEIF(IUED(6).EQ.0)THEN
         RFACT=0.01D0
      ELSE
         WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
         CALL PYSTOP(6001)
      ENDIF

c...Take into account only the strong interactions:

c...The space bulk corrections :
      DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
c...The boundary terms:
      DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM

c...Mass corrections for fermions are extracted from 
c...Phys. Rev. D66 036005(2002)9
      DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
     .     +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
      DBMQU=RMKK*(3.*(ALPHS/4./PI)
     .     +(ALPHEM/4./PI/CW2))*LOGLAM
      DBMQD=RMKK*(3.*(ALPHS/4./PI)
     .     +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
      
      DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
     .     (ALPHEM/4./PI/CW2))*LOGLAM
      DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
      
c...Vector boson masss matrix diagonalization
      DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
      DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
      DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
      DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
      
c...Elements of the mass matrix
      A = RMZ2*SW2 + DBMB2 + DSMB2
      B = RMZ2*CW2 + DBMA2 + DSMA2
      C = RMZ2*DSQRT(SW2*CW2)
      SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )

c...Eigenvalues: corrections to X1 and Z1 masses
      DMB2 = (A+B-SQRDEL)/2. 
      DMA2 = (A+B+SQRDEL)/2. 
      
c...Rotation angles     
      SWW1 = 2*C
      CWW1 = A-B-SQRDEL
C...Weinberg angle
      SW21= SWW1**2/(SWW1**2 + CWW1**2)
      CW21= 1. - SW21
      
      SW021=SW21
      CW021=CW21
      
c...Masses:
      RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
      
      RMDQST=RMKK+RFACT*DBMQDO
      RMSQUS=RMKK+RFACT*DBMQU
      RMSQDS=RMKK+RFACT*DBMQD

C...Note: MZ mass is included in ma2
      RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
      RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
      RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)

      RMLSLD=RMKK+RFACT*DBMLDO
      RMLSLE=RMKK+RFACT*DBMLE

      DO 100 IPART=1,5,2
        PMAS(KKFLA+IPART,1)=RMSQDS
 100  CONTINUE
      DO 110 IPART=2,6,2
        PMAS(KKFLA+IPART,1)=RMSQUS
 110  CONTINUE
      DO 120 IPART=7,12
        PMAS(KKFLA+IPART,1)=RMDQST
 120  CONTINUE
      DO 130 IPART=13,15
        PMAS(KKFLA+IPART,1)=RMLSLE
 130  CONTINUE
      DO 140 IPART=16,21
        PMAS(KKFLA+IPART,1)=RMLSLD
 140  CONTINUE
      PMAS(KKFLA+22,1)=RMGST
      PMAS(KKFLA+23,1)=RMPHST
      PMAS(KKFLA+24,1)=RMZST
      PMAS(KKFLA+25,1)=RMWST

      WRITE(MSTU(11),7000) ' PYUEDC: ',
     & 'UED Mass Spectrum (GeV) :'
      WRITE(MSTU(11),7100) '   m(d*_S,s*_S,b*_S) = ',RMSQDS
      WRITE(MSTU(11),7100) '   m(u*_S,c*_S,t*_S) = ',RMSQUS
      WRITE(MSTU(11),7100) '   m(q*_D)           = ',RMDQST
      WRITE(MSTU(11),7100) '   m(l*_S)           = ',RMLSLE
      WRITE(MSTU(11),7100) '   m(l*_D)           = ',RMLSLD
      WRITE(MSTU(11),7100) '   m(g*)             = ',RMGST
      WRITE(MSTU(11),7100) '   m(gamma*)         = ',RMPHST
      WRITE(MSTU(11),7100) '   m(Z*)             = ',RMZST
      WRITE(MSTU(11),7100) '   m(W*)             = ',RMWST
      WRITE(MSTU(11),7000) ' '

C...Initialize widths, branching ratios and life time
      DO 199 IPART=1,25
        KC=KKFLA+IPART
        IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
          CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
          IF(WDTP(0).LE.0)THEN
             WRITE(MSTU(11),*) 
     +             'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
             WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
             GOTO 199
          ELSE
            DO 180 IDC=1,MDCY(KC,3)
              IC=IDC+MDCY(KC,2)-1
              IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
C...Life time in cm^{-1}.  paru(3) gev^{-1} -> fm
                PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
                BRAT(IC)=WDTP(IDC)/WDTP(0)
              ENDIF
 180        CONTINUE
          ENDIF
        ENDIF
 199  CONTINUE

C...Format to use for comments
 7000 FORMAT(' * ',A)
 7100 FORMAT(' * ',A,F12.3)

      END
C********************************************************************
C...PYXUED
C... Last change: 
C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
C... Original version:
C... M. El Kacimi
C... 05/07/2005
C     Universal Extra Dimensions Subprocess cross sections  
C     The expressions used are from atl-com-phys-2005-003
C     What is coded here is shat**2/pi * dsigma/dt = |M|**2
C     For each UED subprocess, the color flow used is the same 
C     as the equivalent QCD subprocess. Different configuration
C     color flows are considered to have the same probability. 
C
C     The Xsection is calculated following ATL-PHYS-PUB-2005-003
C     by G.Azuelos and P.H.Beauchemin.
C
C     This routine is called from pysigh.

      SUBROUTINE PYXUED(NCHN,SIGS)

C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...
      INTEGER NGRDEC
      COMMON/DECMOD/NGRDEC
C...
      PARAMETER(KKPART=25,KKFLA=450)
C...Commonblocks
      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/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
      COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
     &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
     &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
     &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
      SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
C...UED Pythia common
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
C...Local arrays and complex variables
      DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
     + ,FAC1,XMNKK,XMUED,SIGS
      INTEGER NCHN

C...Return if UED not switched on
      IF (IUED(1).LE.0) THEN 
        RETURN 
      ENDIF

C...Energy scale of the parton processus
C...taken equal to the mass of the final state kk
c      Q2=XMNKK**2      

C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
      XMNKK=PMAS(KKFLA+23,1) 

C...To compare the cross section with phys-pub-2005-03
C...(no radiative corrections), 
C...take xmnkk=rinv  and q2=rinv**2
c++lnk
C...n.b. (rinv=rued(1))
c      IF(NGRDEC.EQ.1)XMNKK=RUED(0)
      IF(NGRDEC.EQ.1)XMNKK=RUED(1)
c--lnk

      SHAT=VINT(44)
      SP=SHAT
      THAT=VINT(45)
      TP=THAT-XMNKK**2
      UHAT=VINT(46)
      UP=UHAT-XMNKK**2
      BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
      PI=DACOS(-1.D0)
c++lnk
c      Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
      Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP

c      IF(NGRDEC.EQ.1)Q2=RUED(0)**2
      IF(NGRDEC.EQ.1)Q2=RUED(1)**2
c--lnk

C...Strong coupling value
      ALPHAS=PYALPS(Q2)

      IF(ISUB.EQ.311)THEN
C...gg --> g* g*
         FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
         XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
     &        24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
     &        +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
     &        12.*TP**2*UP**3+6*TP*UP**4)
     &        +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
     &        15.*TP**3*UP**3+13*TP**2*UP**4+
     &        6.*TP*UP**5+2.*UP**6)
         NCHN=NCHN+1
         ISIG(NCHN,1)=21
         ISIG(NCHN,2)=21
C...Three color flow configurations (qcd g+g->g+g)
         XCOL=PYR(0)
         IF(XCOL.LE.1./3.)THEN
            ISIG(NCHN,3)=1
         ELSEIF(XCOL.LE.2./3.)THEN
            ISIG(NCHN,3)=2
         ELSE
            ISIG(NCHN,3)=3
         ENDIF
         SIGH(NCHN)=COMFAC*XMUED
      ELSEIF(ISUB.EQ.312)THEN
C...q + g -> q*_D + g*, q*_S + g*
C...(the two channels have the same cross section)
         FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
         XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
     &          5.*SP**4*UP**2+12.*SP**5*UP)
         XMUED=COMFAC*2.*XMUED 

          DO 190 I=MMINA,MMAXA
            IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
            DO 180 ISDE=1,2

              IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
              IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
              NCHN=NCHN+1
              ISIG(NCHN,ISDE)=I
              ISIG(NCHN,3-ISDE)=21
              ISIG(NCHN,3)=1
              SIGH(NCHN)=XMUED
              IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
  180       CONTINUE
  190     CONTINUE

      ELSEIF(ISUB.EQ.313)THEN
C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj 
C...(the two channels have the same cross section)
C...qi and qj have the same charge sign 
         DO 100 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
            DO 101 J=MMIN2,MMAX2
               JA=IABS(J)
               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
     &           EQ.0) GOTO 101
               IF(J*I.LE.0)GOTO 101
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=J
               IF(J.EQ.I)THEN
                  FAC1=1./72.*ALPHAS**2/(TP*UP)**2
                  XMUED=FAC1*
     &                  (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
     &                 +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
     &                 20.*TP**2*UP**2+56./3.*
     &                 TP*UP**3+8.*UP**4)
                  SIGH(NCHN)=COMFAC*2.*XMUED
                  ISIG(NCHN,3)=1
                  IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
               ELSE
                  FAC1=2./9.*ALPHAS**2/TP**2
                  XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)     
                  SIGH(NCHN)=COMFAC*2.*XMUED
                  ISIG(NCHN,3)=1
               ENDIF
 101       CONTINUE
 100    CONTINUE
      ELSEIF(ISUB.EQ.314)THEN
C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar 
C...(the two channels have the same cross section)
         NCHN=NCHN+1
         ISIG(NCHN,1)=21
         ISIG(NCHN,2)=21
         ISIG(NCHN,3)=INT(1.5+PYR(0))

         FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
         XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
     +          +4.*UP**4+4*TP**4)
     +          -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
     +          *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
     +          2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
         
         SIGH(NCHN)=COMFAC*XMUED 
C...has been multiplied by 5: all possible quark flavors in final state

      ELSEIF(ISUB.EQ.315)THEN
C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...(the two channels have the same cross section)
          DO 141 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
            DO 142 J=MMIN2,MMAX2
               IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
               FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
               XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
     &              4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
     &              2./3.*SP**3*TP+SP**4)                  
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=-I
               ISIG(NCHN,3)=1
               SIGH(NCHN)=COMFAC*2.*XMUED
 142        CONTINUE
 141      CONTINUE
      ELSEIF(ISUB.EQ.316)THEN
C...q + qbar' -> q*_D + q*_Sbar' 
         FAC1=2./9.*ALPHAS**2
         DO 300 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
            DO 301 J=MMIN2,MMAX2
               JA=IABS(J)
               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
               IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=J
               ISIG(NCHN,3)=1
               FAC1=2./9.*ALPHAS**2/TP**2
               XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
               SIGH(NCHN)=COMFAC*XMUED 
 301       CONTINUE
 300   CONTINUE
               
      ELSEIF(ISUB.EQ.317)THEN
C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar' 
C...(the two channels have the same cross section)
         DO 400 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400     
            DO 401 J=MMIN1,MMAX1
               JA=IABS(J)
               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
               IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=J
               ISIG(NCHN,3)=1
               FAC1=1./18.*ALPHAS**2/TP**2
               XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)  
               SIGH(NCHN)=COMFAC*2.*XMUED 
 401       CONTINUE
 400   CONTINUE
      ELSEIF(ISUB.EQ.318)THEN
C...q + q' -> q*_D + q*_S'
         DO 500 I=MMIN1,MMAX1
            IA=IABS(I)
            IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500   
            DO 501 J=MMIN2,MMAX2
               JA=IABS(J)
               IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501 
               IF(J*I.LE.0)GOTO 501
               IF(IA.EQ.JA)THEN
                  NCHN=NCHN+1
                  ISIG(NCHN,1)=I
                  ISIG(NCHN,2)=J
                  ISIG(NCHN,3)=INT(1.5+PYR(0))
                  FAC1=1./36.*ALPHAS**2/(TP*UP)**2
               XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
     &                 +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
                  SIGH(NCHN)=COMFAC*XMUED              
               ELSE
                  NCHN=NCHN+1
                  ISIG(NCHN,1)=I
                  ISIG(NCHN,2)=J
                  ISIG(NCHN,3)=1
                  FAC1=1./18.*ALPHAS**2/TP**2
                  XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
                  SIGH(NCHN)=COMFAC*2.*XMUED
               ENDIF
 501        CONTINUE
 500     CONTINUE
      ELSEIF(ISUB.EQ.319)THEN
C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
C...(the two channels have the same cross section)
          DO 741 I=MMIN1,MMAX1
            IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
     &      KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
            DO 742 J=MMIN2,MMAX2
               IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
               FAC1=16./9.*ALPHAS**2*1./(SP)**2
               XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
               NCHN=NCHN+1
               ISIG(NCHN,1)=I
               ISIG(NCHN,2)=-I
               ISIG(NCHN,3)=1
               SIGH(NCHN)=COMFAC*2.*XMUED
 742        CONTINUE
 741      CONTINUE   
       
      ENDIF

      RETURN
      END
C*********************************************************************
 
C...PYGRAM
C...Universal Extra Dimensions Model (UED)
C...Computation of the Graviton mass.

      SUBROUTINE PYGRAM(IN)

C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Pythia commonblocks
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)      
C...UED Pythia common
      COMMON/PYPUED/IUED(0:99),RUED(0:99)

C...Local variables
      INTEGER KCFLA,NMAX
      PARAMETER(KCFLA=450,NMAX=5000)
      DIMENSION YVEC(5000),RESVEC(5000)
      COMMON/INTSAV/YSAV,YMAX,RESMAX
      COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
      COMMON/KAPPA/XKAPPA

C...External function (used in call to PYGAUS)
      EXTERNAL PYGRAW

C...SAVE statements
      SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/

C...Initialization
      NDIM=IUED(4)
      RINV=RUED(1)
      XMD=RUED(2)
      PI=PARU(1)

C...Initialize for numerical integration
      XMPLNK=2.4D+18
      XKAPPA=DSQRT(2.D0)/XMPLNK      

C...For NDIM=2, compute graviton mass distribution numerically
      IF(NDIM.EQ.2)THEN
        
C...  For first event: tabulate distribution of stepwise integrals:
C...  int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
        IF(IN.EQ.0)THEN
          RESMAX = 0D0
          YMAX   = 0D0
          DO 100 I=1,NMAX
            YSAV = (I-0.5)/DBLE(NMAX)
            TOL       = 1D-6
C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
            RESINT    = PYGAUS(PYGRAW,0D0,1D0,TOL)
            YVEC(I)   = YSAV
            RESVEC(I) = RESINT
C...  Save max of distribution (for accept/reject below)
            IF(RESINT.GT.RESMAX)THEN
              RESMAX = RESINT
              YMAX   = YVEC(I)
            ENDIF
 100      CONTINUE
        ENDIF
        
C...  Generate Mg for each graviton (1D0 ensures a minimal open phase space)
        PCUJET=1D0
        KCGAKK=KCFLA+23
        XMGAMK=PMAS(KCGAKK,1)
        
C...  Pick random graviton mass, accept according to stored integrals
        AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
 110    RMG=AMMAX*PYR(0)
        X=RMG/XMGAMK        

C...  Bin enumeration starts at 1, but make sure always in range
        IBIN=INT(NMAX*X)+1
        IBIN=MIN(IBIN,NMAX)        
        IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
        
C...  For NDIM=4 and 6, the analytical expression for the
C...  graviton mass distribution integral is used.
      ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
        
C...  Ensure minimal open phase space (max(mG*) < m(gamma*))
        PCUJET=1D0
        
C...  KK photon (?) compressed code and mass
        KCGAKK=KCFLA+23
        XMGAMK=PMAS(KCGAKK,1)
        
C...  Find maximum of (dGamma/dMg)
        IF(IN.EQ.0)THEN
          RESMAX=0D0
          YMAX=0D0
          DO 120 I=1,NMAX-1 
            Y=I/DBLE(NMAX)
            RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
            IF(RESINT.GE.RESMAX)THEN
              RESMAX=RESINT
              YMAX=Y
            ENDIF
 120      CONTINUE
        ENDIF
        
C...  Pick random graviton mass, accept/reject
        AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
 130    RMG=AMMAX*PYR(0)
        X=RMG/XMGAMK
        DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
        IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
        
C...  If the user has not chosen N=2,4 or 6, STOP
      ELSE
        WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
     &       ' (MUST BE 2, 4, OR 6) '
        CALL PYSTOP(6002)
      ENDIF
      
C...  Now store the sampled Mg
      PMAS(39,1)=RMG
      
      RETURN
      END
      
C*********************************************************************
 
C...PYGRAW
C...Universal Extra Dimensions Model (UED)
C...
C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
C...
C...Integrand for the KK boson -> SM boson + graviton
C...graviton mass distribution (and gravity mediated total width),
C...which contains (see 0201300 and below for the full product)
C...the gravity mediated partial decay width Gamma(xx, yy)
C... i.e. GRADEN(YY)*PYWDKK(XXA)
C...  where xx is exclusive to gravity
C...  yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
C...  and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.

      DOUBLE PRECISION FUNCTION PYGRAW(YIN)

C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)

C...Pythia commonblocks
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)

C...Local UED commonblocks and variables
      COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
      COMMON/INTSAV/YSAV,YMAX,RESMAX

C...SAVE statements
      SAVE /PYDAT1/,/INTSAV/

C...External: Pythia's Gamma function
      EXTERNAL PYGAMM

C...Pi
      PI=PARU(1)
      PI2=PI*PI

      YMIN=1.D-9/RINV
      YY=YSAV
      XX=DSQRT(1.-YY**2)*YIN
      DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
      FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
      XND=(NDIM-1.)/2.
      GAMMN=PYGAMM(XND)
      FAC=FAC/GAMMN
      XXA=DSQRT(XX**2+YY**2)
      GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))

      PYGRAW=DJAC*
     +     FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)

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

C...PYWDKK
C...Universal Extra Dimensions Model (UED)
C...
C...Multiplied by the square modulus of a form factor
C...(see GRADEN in function PYGRAW)
C...PYWDKK is the KK boson -> SM boson + graviton
C...gravity mediated partial decay width Gamma(xx, yy)
C...  where xx is exclusive to gravity
C...  yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
C...  and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
C...
C...N.B. The Feynman rules for the couplings of the graviton fields
C...to the UED fields are related to the corresponding couplings of
C...the graviton fields to the SM fields by the form factor.

      DOUBLE PRECISION FUNCTION PYWDKK(X)

C...Double precision and integer declarations
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)

C...Pythia commonblocks
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)

C...Local UED commonblocks and variables
      COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
      COMMON/KAPPA/XKAPPA

C...SAVE statements
      SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/

      PI=PARU(1)

C...gamma* mass 473
      KCQKK=473
      XMNKK=PMAS(KCQKK,1)

C...Bosons partial width Macesanu hep-ph/0201300
      PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
     +          ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))

      RETURN
      END
 
C*********************************************************************
 
C...PYEIGC
C...Finds eigenvalues of a general complex matrix
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
 
      SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
 
      INTEGER N,NM,IS1,IS2,IERR,MATZ
      DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
     X       FV1(5),FV2(5),FV3(5)
      IF (N .LE. NM) GOTO 100
      IERR = 10 * N
      GOTO 120
C
  100 CALL  PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
      CALL  PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
      IF (MATZ .NE. 0) GOTO 110
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
      GOTO 120
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
  110 CALL  PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
      IF (IERR .NE. 0) GOTO 120
      CALL  PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
  120 RETURN
      END
 
C*********************************************************************
 
C...PYCMQR
C...Auxiliary to PYEICG.
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 PYCDIV FOR COMPLEX DIVISION.
C     CALLS PYCSRT 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
 
      SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
 
      INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
      DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
     X       PYTHAG
 
      IERR = 0
      IF (LOW .EQ. IGH) GOTO 130
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
      L = LOW + 1
C
      DO 120 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
         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 100 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
  100    CONTINUE
C
         DO 110 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
  110    CONTINUE
C
  120 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  130 DO 140 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  140 CONTINUE
C
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  150 IF (EN .LT. LOW) GOTO 320
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
  160 DO 170 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GOTO 180
         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) GOTO 180
  170 CONTINUE
C     .......... FORM SHIFT ..........
  180 IF (L .EQ. EN) GOTO 300
      IF (ITN .EQ. 0) GOTO 310
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
      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) GOTO 210
      YR = (HR(ENM1,ENM1) - SR) / 2.0D0
      YI = (HI(ENM1,ENM1) - SI) / 2.0D0
      CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
      ZZR = -ZZR
      ZZI = -ZZI
  190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GOTO 210
C     .......... FORM EXCEPTIONAL SHIFT ..........
  200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.0D0
C
  210 DO 220 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  220 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 240 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 230 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
  230    CONTINUE
C
  240 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0D0) GOTO 250
      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) ..........
  250 DO 280 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 270 I = L, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GOTO 260
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  260       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
  270    CONTINUE
C
  280 CONTINUE
C
      IF (SI .EQ. 0.0D0) GOTO 160
C
      DO 290 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
  290 CONTINUE
C
      GOTO 160
C     .......... A ROOT FOUND ..........
  300 WR(EN) = HR(EN,EN) + TR
      WI(EN) = HI(EN,EN) + TI
      EN = ENM1
      GOTO 150
C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C                CONVERGED AFTER 30*N ITERATIONS ..........
  310 IERR = EN
  320 RETURN
      END
 
C*********************************************************************
 
C...PYCMQ2
C...Auxiliary to PYEICG.
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 PYCDIV FOR COMPLEX DIVISION.
C     CALLS PYCSRT 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  MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
C  MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
C
 
      SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
 
      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(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
     X       ORTR(5),ORTI(5)
      DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
     X       PYTHAG
 
      IERR = 0
C     .......... INITIALIZE EIGENVECTOR MATRIX ..........
      DO 110 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
  110 CONTINUE
C     .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
C                FROM THE INFORMATION LEFT BY CORTH ..........
      IEND = IGH - LOW - 1
      IF (IEND.LT.0) GOTO 220
      IF (IEND.EQ.0) GOTO 170
C     .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 160 II = 1, IEND
         I = IGH - II
         IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
         IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
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 120 K = IP1, IGH
            ORTR(K) = HR(K,I-1)
            ORTI(K) = HI(K,I-1)
  120    CONTINUE
C
         DO 150 J = I, IGH
            SR = 0.0D0
            SI = 0.0D0
C
            DO 130 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)
  130       CONTINUE
C
            SR = SR / NORM
            SI = SI / NORM
C
            DO 140 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)
  140       CONTINUE
C
  150    CONTINUE
C
  160 CONTINUE
C     .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
  170 L = LOW + 1
C
      DO 210 I = L, IGH
         LL = MIN0(I+1,IGH)
         IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
         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 180 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
  180    CONTINUE
C
         DO 190 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
  190    CONTINUE
C
         DO 200 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
  200    CONTINUE
C
  210 CONTINUE
C     .......... STORE ROOTS ISOLATED BY CBAL ..........
  220 DO 230 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
         WR(I) = HR(I,I)
         WI(I) = HI(I,I)
  230 CONTINUE
C
      EN = IGH
      TR = 0.0D0
      TI = 0.0D0
      ITN = 30*N
C     .......... SEARCH FOR NEXT EIGENVALUE ..........
  240 IF (EN .LT. LOW) GOTO 430
      ITS = 0
      ENM1 = EN - 1
C     .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
C                FOR L=EN STEP -1 UNTIL LOW DO -- ..........
  250 DO 260 LL = LOW, EN
         L = EN + LOW - LL
         IF (L .EQ. LOW) GOTO 270
         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) GOTO 270
  260 CONTINUE
C     .......... FORM SHIFT ..........
  270 IF (L .EQ. EN) GOTO 420
      IF (ITN .EQ. 0) GOTO 550
      IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
      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) GOTO 300
      YR = (HR(ENM1,ENM1) - SR) / 2.0D0
      YI = (HI(ENM1,ENM1) - SI) / 2.0D0
      CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
      IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
      ZZR = -ZZR
      ZZI = -ZZI
  280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
      SR = SR - XR
      SI = SI - XI
      GOTO 300
C     .......... FORM EXCEPTIONAL SHIFT ..........
  290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
      SI = 0.0D0
C
  300 DO 310 I = LOW, EN
         HR(I,I) = HR(I,I) - SR
         HI(I,I) = HI(I,I) - SI
  310 CONTINUE
C
      TR = TR + SR
      TI = TI + SI
      ITS = ITS + 1
      ITN = ITN - 1
C     .......... REDUCE TO TRIANGLE (ROWS) ..........
      LP1 = L + 1
C
      DO 330 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 320 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
  320    CONTINUE
C
  330 CONTINUE
C
      SI = HI(EN,EN)
      IF (SI .EQ. 0.0D0) GOTO 350
      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) GOTO 350
      IP1 = EN + 1
C
      DO 340 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
  340 CONTINUE
C     .......... INVERSE OPERATION (COLUMNS) ..........
  350 DO 390 J = LP1, EN
         XR = WR(J-1)
         XI = WI(J-1)
C
         DO 370 I = 1, J
            YR = HR(I,J-1)
            YI = 0.0D0
            ZZR = HR(I,J)
            ZZI = HI(I,J)
            IF (I .EQ. J) GOTO 360
            YI = HI(I,J-1)
            HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
  360       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
  370    CONTINUE
C
         DO 380 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
  380    CONTINUE
C
  390 CONTINUE
C
      IF (SI .EQ. 0.0D0) GOTO 250
C
      DO 400 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
  400 CONTINUE
C
      DO 410 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
  410 CONTINUE
C
      GOTO 250
C     .......... A ROOT FOUND ..........
  420 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
      GOTO 240
C     .......... ALL ROOTS FOUND.  BACKSUBSTITUTE TO FIND
C                VECTORS OF UPPER TRIANGULAR FORM ..........
  430 NORM = 0.0D0
C
      DO 440 I = 1, N
C
         DO 440 J = I, N
            TR = DABS(HR(I,J)) + DABS(HI(I,J))
            IF (TR .GT. NORM) NORM = TR
  440 CONTINUE
C
      IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
C     .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
      DO 500 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 490 II = 1, ENM1
            I = EN - II
            ZZR = 0.0D0
            ZZI = 0.0D0
            IP1 = I + 1
C
            DO 450 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)
  450       CONTINUE
C
            YR = XR - WR(I)
            YI = XI - WI(I)
            IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
               TST1 = NORM
               YR = TST1
  460          YR = 0.01D0 * YR
               TST2 = NORM + YR
               IF (TST2 .GT. TST1) GOTO 460
  470       CONTINUE
            CALL PYCDIV(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) GOTO 490
            TST1 = TR
            TST2 = TST1 + 1.0D0/TST1
            IF (TST2 .GT. TST1) GOTO 490
            DO 480 J = I, EN
               HR(J,EN) = HR(J,EN)/TR
               HI(J,EN) = HI(J,EN)/TR
  480       CONTINUE
C
  490    CONTINUE
C
  500 CONTINUE
C     .......... END BACKSUBSTITUTION ..........
C     .......... VECTORS OF ISOLATED ROOTS ..........
      DO 520 I = 1, N
         IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
C
         DO 510 J = I, N
            ZR(I,J) = HR(I,J)
            ZI(I,J) = HI(I,J)
  510    CONTINUE
C
  520 CONTINUE
C     .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
C                VECTORS OF ORIGINAL FULL MATRIX.
C                FOR J=N STEP -1 UNTIL LOW DO -- ..........
      DO 540 JJ = LOW, N
         J = N + LOW - JJ
         M = MIN0(J,IGH)
C
         DO 540 I = LOW, IGH
            ZZR = 0.0D0
            ZZI = 0.0D0
C
            DO 530 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)
  530       CONTINUE
C
            ZR(I,J) = ZZR
            ZI(I,J) = ZZI
  540 CONTINUE
C
      GOTO 560
C     .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
C                CONVERGED AFTER 30*N ITERATIONS ..........
  550 IERR = EN
  560 RETURN
      END
 
C*********************************************************************
 
C...PYCDIV
C...Auxiliary to PYCMQR
C
C     COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
C
 
      SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
 
      DOUBLE PRECISION AR,AI,BR,BI,CR,CI
      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
 
C*********************************************************************
 
C...PYCSRT
C...Auxiliary to PYCMQR
C
C     (YR,YI) = COMPLEX DSQRT(XR,XI)
C     BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
C
 
      SUBROUTINE PYCSRT(XR,XI,YR,YI)
 
      DOUBLE PRECISION XR,XI,YR,YI
      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) GOTO 110
      R = (DMIN1(DABS(A),DABS(B))/P)**2
  100 CONTINUE
         T = 4.0D0 + R
         IF (T .EQ. 4.0D0) GOTO 110
         S = R/T
         U = 1.0D0 + 2.0D0*S
         P = U*P
         R = (S/U)**2 * R
      GOTO 100
  110 PYTHAG = P
      RETURN
      END
 
C*********************************************************************
 
C...PYCBAL
C...Auxiliary to PYEICG
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
 
      SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
 
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
      DOUBLE PRECISION C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
 
      RADIX = 16.0D0
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GOTO 150
C     .......... IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE ..........
  100 SCALE(M) = J
      IF (J .EQ. M) GOTO 130
C
      DO 110 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
  110 CONTINUE
C
      DO 120 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
  120 CONTINUE
C
  130 IF(IEXC.EQ.1) GOTO 140
      IF(IEXC.EQ.2) GOTO 180
C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN ..........
  140 IF (L .EQ. 1) GOTO 320
      L = L - 1
C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  150 DO 170 JJ = 1, L
         J = L + 1 - JJ
C
         DO 160 I = 1, L
            IF (I .EQ. J) GOTO 160
            IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
  160    CONTINUE
C
         M = L
         IEXC = 1
         GOTO 100
  170 CONTINUE
C
      GOTO 190
C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT ..........
  180 K = K + 1
C
  190 DO 210 J = K, L
C
         DO 200 I = K, L
            IF (I .EQ. J) GOTO 200
            IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
  200    CONTINUE
C
         M = K
         IEXC = 2
         GOTO 100
  210 CONTINUE
C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
      DO 220 I = K, L
  220 SCALE(I) = 1.0D0
C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  230 NOCONV = .FALSE.
C
      DO 310 I = K, L
         C = 0.0D0
         R = 0.0D0
C
         DO 240 J = K, L
            IF (J .EQ. I) GOTO 240
            C = C + DABS(AR(J,I)) + DABS(AI(J,I))
            R = R + DABS(AR(I,J)) + DABS(AI(I,J))
  240    CONTINUE
C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
         IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
         G = R / RADIX
         F = 1.0D0
         S = C + R
  250    IF (C .GE. G) GOTO 260
         F = F * RADIX
         C = C * B2
         GOTO 250
  260    G = R * RADIX
  270    IF (C .LT. G) GOTO 280
         F = F / RADIX
         C = C / B2
         GOTO 270
C     .......... NOW BALANCE ..........
  280    IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
         G = 1.0D0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 290 J = K, N
            AR(I,J) = AR(I,J) * G
            AI(I,J) = AI(I,J) * G
  290    CONTINUE
C
         DO 300 J = 1, L
            AR(J,I) = AR(J,I) * F
            AI(J,I) = AI(J,I) * F
  300    CONTINUE
C
  310 CONTINUE
C
      IF (NOCONV) GOTO 230
C
  320 LOW = K
      IGH = L
      RETURN
      END
 
C*********************************************************************
 
C...PYCBA2
C...Auxiliary to PYEICG.
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
 
      SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
 
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
      DOUBLE PRECISION S
 
      IF (M .EQ. 0) GOTO 150
      IF (IGH .EQ. LOW) GOTO 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) GOTO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GOTO 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
  150 RETURN
      END
 
C*********************************************************************
 
C...PYCRTH
C...Auxiliary to PYEICG.
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
 
      SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
 
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
      DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
 
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GOTO 210
C
      DO 200 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 100 I = M, IGH
  100    SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
C
         IF (SCALE .EQ. 0.0D0) GOTO 200
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 110 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)
  110    CONTINUE
C
         G = DSQRT(H)
         F = PYTHAG(ORTR(M),ORTI(M))
         IF (F .EQ. 0.0D0) GOTO 120
         H = H + F * G
         G = G / F
         ORTR(M) = (1.0D0 + G) * ORTR(M)
         ORTI(M) = (1.0D0 + G) * ORTI(M)
         GOTO 130
C
  120    ORTR(M) = G
         AR(M,M-1) = SCALE
C     .......... FORM (I-(U*UT)/H) * A ..........
  130    DO 160 J = M, N
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 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)
  140       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 150 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)
  150       CONTINUE
C
  160    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 190 I = 1, IGH
            FR = 0.0D0
            FI = 0.0D0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 170 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)
  170       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 180 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)
  180       CONTINUE
C
  190    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)
  200 CONTINUE
C
  210 RETURN
      END
 
C*********************************************************************
 
C...PYLDCM
C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
C...processes.
 
      SUBROUTINE PYLDCM(A,N,NP,INDX,D)
      IMPLICIT NONE
      INTEGER N,NP,INDX(N)
      REAL*8 D,TINY
      COMPLEX*16 A(NP,NP)
      PARAMETER (TINY=1.0D-20)
      INTEGER I,IMAX,J,K
      REAL*8 AAMAX,VV(6),DUM
      COMPLEX*16 SUM,DUMC
 
      D=1D0
      DO 110 I=1,N
        AAMAX=0D0
        DO 100 J=1,N
          IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
  100   CONTINUE
        IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
        VV(I)=1D0/AAMAX
  110 CONTINUE
      DO 180 J=1,N
        DO 130 I=1,J-1
          SUM=A(I,J)
          DO 120 K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
  120     CONTINUE
          A(I,J)=SUM
  130   CONTINUE
        AAMAX=0D0
        DO 150 I=J,N
          SUM=A(I,J)
          DO 140 K=1,J-1
            SUM=SUM-A(I,K)*A(K,J)
  140     CONTINUE
          A(I,J)=SUM
          DUM=VV(I)*ABS(SUM)
          IF (DUM.GE.AAMAX) THEN
            IMAX=I
            AAMAX=DUM
          ENDIF
  150   CONTINUE
        IF (J.NE.IMAX)THEN
          DO 160 K=1,N
            DUMC=A(IMAX,K)
            A(IMAX,K)=A(J,K)
            A(J,K)=DUMC
  160     CONTINUE
          D=-D
          VV(IMAX)=VV(J)
        ENDIF
        INDX(J)=IMAX
        IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
        IF(J.NE.N)THEN
          DO 170 I=J+1,N
            A(I,J)=A(I,J)/A(J,J)
  170     CONTINUE
        ENDIF
  180 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYBKSB
C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
C...processes.
 
      SUBROUTINE PYBKSB(A,N,NP,INDX,B)
      IMPLICIT NONE
      INTEGER N,NP,INDX(N)
      COMPLEX*16 A(NP,NP),B(N)
      INTEGER I,II,J,LL
      COMPLEX*16 SUM
 
      II=0
      DO 110 I=1,N
        LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF (II.NE.0)THEN
          DO 100 J=II,I-1
            SUM=SUM-A(I,J)*B(J)
  100     CONTINUE
        ELSE IF (ABS(SUM).NE.0D0) THEN
          II=I
        ENDIF
        B(I)=SUM
  110 CONTINUE
      DO 130 I=N,1,-1
        SUM=B(I)
        DO 120 J=I+1,N
          SUM=SUM-A(I,J)*B(J)
  120   CONTINUE
        B(I)=SUM/A(I,I)
  130 CONTINUE
      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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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/PYTCSM/ITCM(0:99),RTCM(0:99)
      SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
     &/PYINT4/,/PYMSSM/,/PYTCSM/
C...Local arrays and saved variables.
      DIMENSION WDTP(0:400),WDTE(0:400,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 I=0,400
        WDTP(I)=0D0
      ENDDO
 
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:
        XWC=1D0/(16D0*XW*XW1)
        FAC=(AEM*XWC/3D0)*SHR
  120   CONTINUE
        DO 130 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 130
          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 130
          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)
          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
          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)
  130   CONTINUE
 
 
      ELSEIF(KFLA.EQ.24) THEN
C...W+/-:
        FAC=(AEM/(24D0*XW))*SHR
        DO 140 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 140
          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 140
          WID2=1D0
          IF(I.LE.16) THEN
C...W+/- -> q + qbar'
            FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
          ELSEIF(I.LE.20) THEN
C...W+/- -> l+/- + nu
            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)
  140   CONTINUE
 
C.....V8 -> quark anti-quark
      ELSEIF(KFLA.EQ.KTECHN+100021) THEN
        FAC=AS/6D0*SHR
        TANT3=RTCM(21)
        IF(ITCM(2).EQ.0) THEN
          IMDL=1
        ELSEIF(ITCM(2).EQ.1) THEN
          IMDL=2
        ENDIF
        DO 150 I=1,MDCY(KC,3)
          IDC=I+MDCY(KC,2)-1
          IF(MDME(IDC,1).LT.0) GOTO 150
          PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
          RM1=PM1**2/SH
          IF(RM1.GT.0.25D0) GOTO 150
          WID2=1D0
          IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
            FMIX=1D0/TANT3**2
          ELSE
            FMIX=TANT3**2
          ENDIF
          WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
          IF(I.EQ.6) WID2=WIDS(6,1)
          WDTP(0)=WDTP(0)+WDTP(I)
  150   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRVSF
C...Calculates R-violating decays of sfermions.
C...P. Z. Skands
 
      SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Commonblocks.
      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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3), PYCOMP
      SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
 
C...IS R-VIOLATION ON ?
      IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
C...Mass eigenstate counter
        ICNT=INT(KFIN/KSUSY1)
C...SM KF code of SUSY particle
        KFSM=KFIN-ICNT*KSUSY1
C...Squared Sparticle Mass
        SM=PMAS(PYCOMP(KFIN),1)**2
C... Squared mass of top quark
        SMT=PMAS(PYCOMP(6),1)**2
C...IS L-VIOLATION ON ?
        IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
          IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
     &         THEN
            K=INT((KFSM-9)/2)
            DO 110 I=1,3
              DO 100 J=1,3
                IF(I.NE.J) THEN
C...~e,~mu,~tau -> nu_I + lepton-_J
                  LKNT = LKNT+1
                  IDLAM(LKNT,1)= 12 +2*(I-1)
                  IDLAM(LKNT,2)= 11 +2*(J-1)
                  IDLAM(LKNT,3)= 0
                  XLAM(LKNT)=0D0
                  RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
                  IF (IMSS(51).NE.0) XLAM(LKNT) =
     &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
                ENDIF
  100         CONTINUE
  110       CONTINUE
C...~e,~mu,~tau -> nu_Ibar + lepton-_K
            J=INT((KFSM-9)/2)
            DO 130 I=1,3
              IF(I.NE.J) THEN
                DO 120 K=1,3
                  LKNT = LKNT+1
                  IDLAM(LKNT,1)=-12 -2*(I-1)
                  IDLAM(LKNT,2)= 11 +2*(K-1)
                  IDLAM(LKNT,3)= 0
                  XLAM(LKNT)=0D0
                  RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
                  IF (IMSS(51).NE.0) XLAM(LKNT) =
     &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
  120           CONTINUE
              ENDIF
  130       CONTINUE
C...~e,~mu,~tau -> u_Jbar + d_K
            I=INT((KFSM-9)/2)
            DO 150 J=1,3
              DO 140 K=1,3
                LKNT = LKNT+1
                IDLAM(LKNT,1)=-2 -2*(J-1)
                IDLAM(LKNT,2)= 1 +2*(K-1)
                IDLAM(LKNT,3)= 0
                XLAM(LKNT)=0
                IF (IMSS(52).NE.0) THEN
C...Use massive top quark
                  IF (IDLAM(LKNT,1).EQ.-6) THEN
                    RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
     &                   * (SM-SMT)
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
C...If no top quark, all decay products massless
                  ELSE
                    RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
                  ENDIF
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
                ENDIF
  140         CONTINUE
  150       CONTINUE
          ENDIF
C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
C...No right-handed neutrinos
          IF(ICNT.EQ.1) THEN
            IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
              J=INT((KFSM-10)/2)
              DO 170 I=1,3
                DO 160 K=1,3
                  IF (I.NE.J) THEN
C...~nu_J -> lepton+_I + lepton-_K
                    LKNT = LKNT+1
                    IDLAM(LKNT,1)=-11 -2*(I-1)
                    IDLAM(LKNT,2)= 11 +2*(K-1)
                    IDLAM(LKNT,3)=  0
                    XLAM(LKNT)=0D0
                    RM2=RVLAM(I,J,K)**2 * SM
                    IF (IMSS(51).NE.0) XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                    IF (XLAM(LKNT).EQ.0D0) THEN
                      LKNT=LKNT-1
                    ENDIF
                  ENDIF
  160           CONTINUE
  170         CONTINUE
C...~nu_I -> dbar_J + d_K
              I=INT((KFSM-10)/2)
              DO 190 J=1,3
                DO 180 K=1,3
                  LKNT = LKNT+1
                  IDLAM(LKNT,1)=-1 -2*(J-1)
                  IDLAM(LKNT,2)= 1 +2*(K-1)
                  IDLAM(LKNT,3)= 0
                  XLAM(LKNT)=0D0
                  RM2=3*RVLAMP(I,J,K)**2 * SM
                  IF (IMSS(52).NE.0) XLAM(LKNT) =
     &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
  180           CONTINUE
  190         CONTINUE
            ENDIF
          ENDIF
C * SDOWN -> NU(BAR) + D and LEPTON- + U
          IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
            J=INT((KFSM+1)/2)
            DO 210 I=1,3
              DO 200 K=1,3
C...~d_J -> nu_Ibar + d_K
                LKNT = LKNT+1
                IDLAM(LKNT,1)=-12 -2*(I-1)
                IDLAM(LKNT,2)=  1 +2*(K-1)
                IDLAM(LKNT,3)=  0
                XLAM(LKNT)=0D0
                RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
                IF (IMSS(52).NE.0) XLAM(LKNT) =
     &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
  200         CONTINUE
  210       CONTINUE
            K=INT((KFSM+1)/2)
            DO 240 I=1,3
              DO 230 J=1,3
C...~d_K -> nu_I + d_J
                LKNT = LKNT+1
                IDLAM(LKNT,1)= 12 +2*(I-1)
                IDLAM(LKNT,2)=  1 +2*(J-1)
                IDLAM(LKNT,3)=  0
                XLAM(LKNT)=0D0
                RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
                IF (IMSS(52).NE.0) XLAM(LKNT) =
     &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
C...~d_K -> lepton_I- + u_J
  220           LKNT = LKNT+1
                IDLAM(LKNT,1)= 11 +2*(I-1)
                IDLAM(LKNT,2)=  2 +2*(J-1)
                IDLAM(LKNT,3)=  0
                XLAM(LKNT)=0D0
                IF (IMSS(52).NE.0) THEN
C...Use massive top quark
                  IF (IDLAM(LKNT,2).EQ.6) THEN
                    RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
C...If no top quark, all decay products massless
                  ELSE
                    RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
                  ENDIF
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
                ENDIF
  230         CONTINUE
  240       CONTINUE
          ENDIF
C * SUP -> LEPTON+ + D
          IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
            J=NINT(KFSM/2.)
            DO 260 I=1,3
              DO 250 K=1,3
C...~u_J -> lepton_I+ + d_K
                LKNT = LKNT+1
                IDLAM(LKNT,1)=-11 -2*(I-1)
                IDLAM(LKNT,2)=  1 +2*(K-1)
                IDLAM(LKNT,3)=  0
                XLAM(LKNT)=0D0
                RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
                IF (IMSS(52).NE.0) XLAM(LKNT) =
     &               PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
  250         CONTINUE
  260       CONTINUE
          ENDIF
        ENDIF
C...BARYON NUMBER VIOLATING DECAYS
        IF (IMSS(53).GE.1) THEN
C * SUP -> DBAR + DBAR
          IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
            I = KFSM/2
            DO 280 J=1,3
              DO 270 K=1,3
C...~u_I -> dbar_J + dbar_K
                IF (J.LT.K) THEN
C...(anti-) symmetry J <-> K.
                  LKNT = LKNT + 1
                  IDLAM(LKNT,1) = -1 -2*(J-1)
                  IDLAM(LKNT,2) = -1 -2*(K-1)
                  IDLAM(LKNT,3) =  0
                  XLAM(LKNT)    =  0D0
                  RM2 = 2.*(RVLAMB(I,J,K)**2)
     &                 * SFMIX(KFSM,2*ICNT)**2 * SM
                  XLAM(LKNT)    =
     &                 PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT = LKNT-1
                  ENDIF
                ENDIF
  270         CONTINUE
  280       CONTINUE
          ENDIF
C * SDOWN -> UBAR + DBAR
          IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
            K=(KFSM+1)/2
            DO 300 I=1,3
              DO 290 J=1,3
C...LAMB coupling antisymmetric in J and K.
                IF (J.NE.K) THEN
C...~d_K -> ubar_I + dbar_K
                  LKNT = LKNT + 1
                  IDLAM(LKNT,1)= -2 -2*(I-1)
                  IDLAM(LKNT,2)= -1 -2*(J-1)
                  IDLAM(LKNT,3)=  0
                  XLAM(LKNT)=0D0
C...Use massive top quark
                  IF (IDLAM(LKNT,1).EQ.-6) THEN
                    RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
     &                   )
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
C...If no top quark, all decay products massless
                  ELSE
                    RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
                    XLAM(LKNT) =
     &                   PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
                  ENDIF
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
                ENDIF
  290         CONTINUE
  300       CONTINUE
          ENDIF
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRVNE
C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
C...P. Z. Skands
 
      SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
      DOUBLE PRECISION XLAM(0:400)
      DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
      INTEGER IDLAM(400,3), PYCOMP
      LOGICAL DCMASS
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
 
C...R-VIOLATING DECAYS
      IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
        KFSM=KFIN-KSUSY1
        IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
C...WHICH NEUTRALINO ?
          NCHI=1
          IF (KFSM.EQ.23) NCHI=2
          IF (KFSM.EQ.25) NCHI=3
          IF (KFSM.EQ.35) NCHI=4
C...SIGN OF MASS (Opposite convention as HERWIG)
          ISM = 1
          IF (SMZ(NCHI).LT.0D0) ISM = -ISM
 
C...Useful parameters for the calculation of the A and B constants.
          WMASS = PMAS(PYCOMP(24),1)
          ECHG = 2*SQRT(PARU(103)*PARU(1))
          COSB=1/(SQRT(1+RMSS(5)**2))
          SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
          COSW=SQRT(1-PARU(102))
          SINW=SQRT(PARU(102))
          GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
C...Run quark masses to neutralino mass squared (for Higgs-type
C...couplings)
          SQMCHI=PMAS(PYCOMP(KFIN),1)**2
          DO 100 I=1,6
            RMQ(I)=PYMRUN(I,SQMCHI)
  100     CONTINUE
C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
            DO 110 NCHJ=1,4
              ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
              ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
              ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
              ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
  110       CONTINUE
            C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
            C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
            C2=ECHG*ZPMIX(NCHI,1)
            C3=GW*ZPMIX(NCHI,2)/COSW
            EU=2D0/3D0
            ED=-1D0/3D0
C... AB(x,y,z):
C       x=1-2  : Select A or B constant     (1:A ; 2:B)
C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C                                    11-16:e,nu_e,mu,...)
C       z=1-2  : Mass eigenstate number
C...CALCULATE COUPLINGS
          DO 120 I = 11,15,2
            CMS=PMAS(PYCOMP(I),1)
C...Intermediate sleptons
            AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
     &           *(C2-C3*SINW**2))
            AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
     &           *(C2-C3*SINW**2))
            AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
     &           **2))
            AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
     &           **2))
C...Inermediate sneutrinos
            AB(1,I+1,1)=0D0
            AB(2,I+1,1)=5D-1*C3
            AB(1,I+1,2)=0D0
            AB(2,I+1,2)=0D0
C...Inermediate sdown
            J=I-10
            CMS=RMQ(J)
            AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
     &           *ED*(C2-C3*SINW**2))
            AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
     &           *ED*(C2-C3*SINW**2))
            AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
     &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
            AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
     &           *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
C...Inermediate sup
            J=J+1
            CMS=RMQ(J)
            AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
     &           *EU*(C2-C3*SINW**2))
            AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
     &           *EU*(C2-C3*SINW**2))
            AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
     &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
            AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
     &           *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
  120     CONTINUE
 
          IF (IMSS(51).GE.1) THEN
C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
C...STEP IN I,J,K USING SINGLE COUNTER
            DO 130 ISC=0,26
C...LAMBDA COUPLING ASYM IN I,J
              IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
                LKNT = LKNT+1
                IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
                IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
                IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
                XLAM(LKNT)    = 0D0
C...Set coupling, and decay product masses on/off
                RVLAMC        = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
     &               ,MOD(ISC,3)+1)**2
                DCMASS=.FALSE.
                IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
     &               DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1)=-IDLAM(LKNT,1)
                KFR(2)=-IDLAM(LKNT,2)
                KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XLAM(LKNT))
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
                LKNT=LKNT+1
                IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
                IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
                IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
                XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-2
                ENDIF
              ENDIF
  130       CONTINUE
          ENDIF
 
          IF (IMSS(52).GE.1) THEN
C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
C * CHI0 -> NUBAR_I + DBAR_J + D_K
            DO 140 ISC=0,26
              LKNT = LKNT+1
              IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              RVLAMC        = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
     &             ,MOD(ISC,3)+1)**2
              DCMASS=.FALSE.
              IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
     &             DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=-IDLAM(LKNT,1)
              KFR(2)=-IDLAM(LKNT,2)
              KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
              LKNT=LKNT+1
              IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
              IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
              IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
              XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-2
              ENDIF
 
C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
              LKNT = LKNT+1
              IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              RVLAMC        = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
     &             ,MOD(ISC,3)+1)**2
              DCMASS=.FALSE.
              IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
     &             .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=-IDLAM(LKNT,1)
              KFR(2)=-IDLAM(LKNT,2)
              KFR(3)=-IDLAM(LKNT,3)
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
              LKNT=LKNT+1
              IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
              IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
              IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
              XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-2
              ENDIF
  140       CONTINUE
          ENDIF
 
          IF (IMSS(53).GE.1) THEN
C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
            DO 150 ISC=0,26
C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
              IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
                LKNT = LKNT+1
                IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
                IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
                IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
                XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
                RVLAMC        = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
     &               +1,MOD(ISC,3)+1)**2
                DCMASS=.FALSE.
                IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
     &               .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = IDLAM(LKNT,1)
                KFR(2) = IDLAM(LKNT,2)
                KFR(3) = IDLAM(LKNT,3)
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XLAM(LKNT))
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
                LKNT=LKNT+1
                IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
                IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
                IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
                XLAM(LKNT)=XLAM(LKNT-1)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-2
                ENDIF
              ENDIF
  150       CONTINUE
          ENDIF
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRVCH
C...Calculates R-violating chargino decay widths.
C...P. Z. Skands
 
      SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3), PYCOMP
C...Information from main routine to PYRVGW
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
C...Auxiliary variables needed for BV (RV Gauge STOre)
      COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
     &     ,RVLJKI,RVLJIK
C...Running quark masses
      DOUBLE PRECISION RMQ(6)
C...Decay product masses on/off
      LOGICAL DCMASS
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
     &     /RVGSTO/
 
 
C...IF R-VIOLATION ON.
      IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
        KFSM=KFIN-KSUSY1
        IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
C...WHICH CHARGINO ?
          NCHI = 1
          IF (KFSM.EQ.37) NCHI = 2
 
C...Useful parameters for calculating the A and B constants.
C...SIGN OF MASS (Opposite convention as HERWIG)
          ISM  = 1
          IF (SMW(NCHI).LT.0D0) ISM = -1
          WMASS   = PMAS(PYCOMP(24),1)
          COSB    = 1/(SQRT(1+RMSS(5)**2))
          SINB    = RMSS(5)/SQRT(1+RMSS(5)**2)
          GW2     = 4*PARU(103)*PARU(1)/PARU(102)
          C1U     = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
          C1V     = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
          C2      = UMIX(NCHI,1)
          C3      = VMIX(NCHI,1)
C...Running masses at Q^2=MCHI^2.
          SQMCHI  = PMAS(PYCOMP(KFSM),1)**2
          DO 100 I=1,6
            RMQ(I)=PYMRUN(I,SQMCHI)
  100     CONTINUE
 
C... AB(x,y,z) coefficients:
C       x=1-2  : A or B coefficient  (1:A ; 2:B)
C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C                                    11-16:e,nu_e,mu,...)
C       z=1-2  : Mass eigenstate number
          DO 110 I = 11,15,2
C...Intermediate sleptons
            AB(1,I,1)   = 0D0
            AB(1,I,2)   = 0D0
            AB(2,I,1)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
     &           SFMIX(I,1)*C2
            AB(2,I,2)   = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
     &           SFMIX(I,3)*C2
C...Intermediate sneutrinos
            AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
            AB(1,I+1,2) = 0D0
            AB(2,I+1,1) = ISM*C3
            AB(2,I+1,2) = 0D0
C...Intermediate sdown
            J=I-10
            AB(1,J,1)   = -RMQ(J+1)*C1V*SFMIX(J,1)
            AB(1,J,2)   = -RMQ(J+1)*C1V*SFMIX(J,3)
            AB(2,J,1)   = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
            AB(2,J,2)   = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
C...Intermediate sup
            J=J+1
            AB(1,J,1)   = -RMQ(J-1)*C1U*SFMIX(J,1)
            AB(1,J,2)   = -RMQ(J-1)*C1U*SFMIX(J,3)
            AB(2,J,1)   = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
            AB(2,J,2)   = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
  110     CONTINUE
 
C...LLE TYPE R-VIOLATION
          IF (IMSS(51).GE.1) THEN
C...LOOP OVER DECAY MODES
            DO 140 ISC=0,26
 
C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
              IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
                LKNT = LKNT+1
                IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
                IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
                IDLAM(LKNT,3) =  12 +2*MOD(ISC,3)
                XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
                RVLAMC        = GW2 * 5D-1 *
     &               RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
     &               **2
                DCMASS=.FALSE.
                IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K).
                KFR(1) = 0
                KFR(2) = 0
                KFR(3) = -IDLAM(LKNT,3)+1
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XLAM(LKNT))
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
 
C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
  120           IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
                  LKNT = LKNT+1
                  IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
                  IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
                  IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
                  XLAM(LKNT)    = 0D0
C...Set coupling, and decay product masses on/off
                  RVLAMC = GW2 * 5D-1 *
     &              RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
C...I,J SYMMETRY => FACTOR 2
                  RVLAMC=2*RVLAMC
                  DCMASS=.FALSE.
                  IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
                  KFR(1)=IDLAM(LKNT,1)-1
                  KFR(2)=IDLAM(LKNT,2)-1
                  KFR(3)=0
C...Calculate width.
                  CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &                 IDLAM(LKNT,3),XLAM(LKNT))
                 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
                  IF (XLAM(LKNT).EQ.0D0) THEN
                    LKNT=LKNT-1
                  ENDIF
  130           ENDIF
 
C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
                LKNT = LKNT+1
                IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
                IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
                IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
                XLAM(LKNT)    = 0D0
C...Set coupling, and decay product masses on/off
                RVLAMC = GW2 * 5D-1 *
     &             RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
C...I,J SYMMETRY => FACTOR 2
                RVLAMC=2*RVLAMC
                DCMASS=.FALSE.
                IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
     &               .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) =-IDLAM(LKNT,1)+1
                KFR(2) =-IDLAM(LKNT,2)+1
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XLAM(LKNT))
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
              ENDIF
  140       CONTINUE
          ENDIF
 
C...LQD TYPE R-VIOLATION
          IF (IMSS(52).GE.1) THEN
C...LOOP OVER DECAY MODES
            DO 180 ISC=0,26
 
C...CHI+ -> NUBAR_I + DBAR_J + U_K
              LKNT = LKNT+1
              IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              RVLAMC = 3. * GW2 * 5D-1 *
     &           RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
              DCMASS=.FALSE.
              IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
     &             DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=0
              KFR(2)=0
              KFR(3)=-IDLAM(LKNT,3)+1
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-1
              ENDIF
 
C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
  150         LKNT = LKNT+1
              IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) =  2 +2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              RVLAMC = 3. * GW2 * 5D-1 *
     &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
              DCMASS=.FALSE.
              IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
     &             .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=0
              KFR(2)=0
              KFR(3)=-IDLAM(LKNT,3)+1
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-1
              ENDIF
 
C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
  160         LKNT = LKNT+1
              IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              RVLAMC = 3. * GW2 * 5D-1 *
     &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
              DCMASS = .FALSE.
              IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
     &             .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=-IDLAM(LKNT,1)+1
              KFR(2)=-IDLAM(LKNT,2)+1
              KFR(3)=0
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-1
              ENDIF
 
C * CHI+ -> NU_I + U_J + DBAR_K.
  170         LKNT = LKNT+1
              IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
              IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
              IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
              XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
              DCMASS = .FALSE.
              RVLAMC = 3. * GW2 * 5D-1 *
     &             RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
              IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
     &             DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)=IDLAM(LKNT,1)-1
              KFR(2)=IDLAM(LKNT,2)-1
              KFR(3)=0
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XLAM(LKNT))
              XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-1
              ENDIF
 
  180       CONTINUE
          ENDIF
 
C...UDD TYPE R-VIOLATION
C...These decays need special treatment since more than one BV coupling
C...contributes (with interference). Consider e.g. (symbolically)
C      |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
C             +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
C             +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
C...The problem is that a single call to PYRVGW would evaluate all
C...these terms and sum them, but without the different couplings. The
C...way out is to call PYRVGW three times, once for the first line, once
C...for the second line, and then once for all the lines (it is
C...impossible to get just the last line out) without multiplying by
C...couplings. The last line is then obtained as the result of the third
C...call minus the results of the two first calls. Each term is then
C...multiplied by its respective coupling before the whole thing is
C...summed up in XLAM.
C...Note that with three interfering resonances, this procedure becomes
C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
 
          IF (IMSS(53).GE.1) THEN
C...LOOP OVER DECAY MODES
            DO 190 ISC=1,25
 
C...CHI+ -> U_I + U_J + D_K
C...Decay mode I<->J symmetric.
              IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
                LKNT = LKNT+1
                IDLAM(LKNT,1) =  2 +2*MOD(ISC/9,3)
                IDLAM(LKNT,2) =  2 +2*MOD(ISC/3,3)
                IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
                XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
                RVLAMC= 6. * GW2 * 5D-1
                RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
     &               +1)
                RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
     &               +1)
                IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
     &               * RVLAMC
                DCMASS=.FALSE.
                IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
     &               .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = -IDLAM(LKNT,1)+1
                KFR(2) = 0
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = 0
                KFR(2) = -IDLAM(LKNT,2)+1
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = -IDLAM(LKNT,1)+1
                KFR(2) = -IDLAM(LKNT,2)+1
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESIJ)
                IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
                  XRESIJ = XRESIJ-XRESI-XRESJ
                ELSE
                  XRESIJ = 0D0
                ENDIF
C...CALCULATE TOTAL WIDTH
                XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
     &               + RVLJIK*RVLIJK * XRESIJ
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
              ENDIF
C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
C...Symmetry I<->J<->K.
              IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
     &             .MOD(ISC,3)).AND.ISC.NE.13) THEN
                LKNT = LKNT+1
                IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
                IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
                IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
                XLAM(LKNT)    =  0D0
C...Set coupling, and decay product masses on/off
                RVLAMC = 6. * GW2 * 5D-1
                RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
     &               +1)
                RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
     &               +1)
                RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
     &               +1)
                DCMASS = .FALSE.
                IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
     &               .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
C...Collect symmetry factors
                IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
     &               .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
     &               RVLAMC = 5D-1 * RVLAMC
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = IDLAM(LKNT,1)-1
                KFR(2) = 0
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = 0
                KFR(2) = IDLAM(LKNT,2)-1
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = 0
                KFR(2) = 0
                KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESK)
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = IDLAM(LKNT,1)-1
                KFR(2) = IDLAM(LKNT,2)-1
                KFR(3) = 0
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESIJ)
                IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
                  XRESIJ = XRESI+XRESJ-XRESIJ
                ELSE
                  XRESIJ = 0D0
                ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = 0
                KFR(2) = IDLAM(LKNT,2)-1
                KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESJK)
                IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
                  XRESJK = XRESJ+XRESK-XRESJK
                ELSE
                  XRESJK = 0D0
                ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
                KFR(1) = IDLAM(LKNT,1)-1
                KFR(2) = 0
                KFR(3) = IDLAM(LKNT,3)-1
C...Calculate width.
                CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
     &               IDLAM(LKNT,3),XRESIK)
                IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
                  XRESIK = XRESI+XRESK-XRESIK
                ELSE
                  XRESIK = 0D0
                ENDIF
C...CALCULATE TOTAL WIDTH
                XLAM(LKNT) =
     &                 RVLIJK**2 * XRESI
     &               + RVLJKI**2 * XRESJ
     &               + RVLKIJ**2 * XRESK
     &               + RVLIJK*RVLJKI * XRESIJ
     &               + RVLIJK*RVLKIJ * XRESIK
     &               + RVLJKI*RVLKIJ * XRESJK
                XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
C...KINEMATICS CHECK
                IF (XLAM(LKNT).EQ.0D0) THEN
                  LKNT=LKNT-1
                ENDIF
              ENDIF
  190       CONTINUE
          ENDIF
        ENDIF
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRVGL
C...Calculates R-violating gluino decay widths.
C...See BV part of PYRVCH for comments about the way the BV decay width
C...is calculated. Same comments apply here.
C...P. Z. Skands
 
      SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
C...Local variables.
      DOUBLE PRECISION XLAM(0:400)
      INTEGER IDLAM(400,3), PYCOMP
C...Information from main routine to PYRVGW
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
C...Auxiliary variables needed for BV (RV Gauge STOre)
      COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
     &     ,RVLJKI,RVLJIK
C...Running quark masses
      DOUBLE PRECISION RMQ(6)
C...Decay product masses on/off
      LOGICAL DCMASS
      SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
     &     /RVGSTO/
 
C...IF LQD OR UDD TYPE R-VIOLATION ON.
      IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
        KFSM=KFIN-KSUSY1
 
C... AB(x,y,z):
C       x=1-2  : Select A or B coupling     (1:A ; 2:B)
C       y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
C                                    11-16:e,nu_e,mu,... not used here)
C       z=1-2  : Mass eigenstate number
        DO 100 I = 1,6
C...A Couplings
          AB(1,I,1) = SFMIX(I,2)
          AB(1,I,2) = SFMIX(I,4)
C...B Couplings
          AB(2,I,1) = -SFMIX(I,1)
          AB(2,I,2) = -SFMIX(I,3)
  100   CONTINUE
        GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
C...LQD DECAYS.
        IF (IMSS(52).GE.1) THEN
C...STEP IN I,J,K USING SINGLE COUNTER
          DO 120 ISC=0,26
C * GLUINO -> NUBAR_I + DBAR_J + D_K.
            LKNT          = LKNT+1
            IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
            IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
            IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
            XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off
            RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
     &           * 5D-1 * GSTR2
            DCMASS        = .FALSE.
            IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
            KFR(1)        = 0
            KFR(2)        = -IDLAM(LKNT,2)
            KFR(3)        = -IDLAM(LKNT,3)
C...Calculate width.
            CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &           ,XLAM(LKNT))
C...Normalize
            XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
  110       LKNT          = LKNT+1
            IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
            IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
            IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
            XLAM(LKNT)    = XLAM(LKNT-1)
C...KINEMATICS CHECK
            IF (XLAM(LKNT).EQ.0D0) THEN
              LKNT=LKNT-2
            ENDIF
 
C * GLUINO -> LEPTON+_I + UBAR_J + D_K
            LKNT = LKNT+1
            IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
            IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
            IDLAM(LKNT,3) =  1 +2*MOD(ISC,3)
            XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off
            RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
     &           **2* 5D-1 * GSTR2
            DCMASS        = .FALSE.
            IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
     &           .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
            KFR(1)        = 0
            KFR(2)        = -IDLAM(LKNT,2)
            KFR(3)        = -IDLAM(LKNT,3)
C...Calculate width.
            CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &           ,XLAM(LKNT))
            XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
            LKNT=LKNT+1
            IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
            IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
            IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
            XLAM(LKNT)    =  XLAM(LKNT-1)
C...KINEMATICS CHECK
            IF (XLAM(LKNT).EQ.0D0) THEN
              LKNT=LKNT-2
            ENDIF
 
  120     CONTINUE
        ENDIF
 
C...UDD DECAYS.
        IF (IMSS(53).GE.1) THEN
C...STEP IN I,J,K USING SINGLE COUNTER
          DO 130 ISC=0,26
C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
            IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
              LKNT          = LKNT+1
              IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
              IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
              IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
              XLAM(LKNT)=0D0
C...Set coupling, and decay product masses on/off. A factor of 2 for
C...(N_C-1) has been used to cancel a factor 0.5.
              RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
     &             **2 * GSTR2
              DCMASS        = .FALSE.
              IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
     &             .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = IDLAM(LKNT,1)
              KFR(2)        = 0
              KFR(3)        = 0
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESI)
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = 0
              KFR(2)        = IDLAM(LKNT,2)
              KFR(3)        = 0
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESJ)
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = 0
              KFR(2)        = 0
              KFR(3)        = IDLAM(LKNT,3)
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESK)
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = IDLAM(LKNT,1)
              KFR(2)        = IDLAM(LKNT,2)
              KFR(3)        = 0
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESIJ)
C...Calculate interference function. (Factor -1/2 to make up for factor
C...-2 in PYRVGW.
              IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
                XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
              ELSE
                XRESIJ = 0D0
              ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = 0
              KFR(2)        = IDLAM(LKNT,2)
              KFR(3)        = IDLAM(LKNT,3)
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESJK)
              IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
                XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
              ELSE
                XRESJK = 0D0
              ENDIF
C...Resonance KF codes (1=I,2=J,3=K)
              KFR(1)        = IDLAM(LKNT,1)
              KFR(2)        = 0
              KFR(3)        = IDLAM(LKNT,3)
C...Calculate width.
              CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
     &             ,XRESIK)
              IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
                XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
              ELSE
                XRESIK = 0D0
              ENDIF
C...Calculate total width (factor 1/2 from 1/(N_C-1))
              XLAM(LKNT) = XRESI + XRESJ + XRESK
     &             + 5D-1 * (XRESIJ + XRESIK + XRESJK)
C...Normalize
              XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
C...Charge conjugate mode.
              LKNT          = LKNT+1
              IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
              IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
              IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
              XLAM(LKNT)    = XLAM(LKNT-1)
C...KINEMATICS CHECK
              IF (XLAM(LKNT).EQ.0D0) THEN
                LKNT=LKNT-2
              ENDIF
            ENDIF
  130     CONTINUE
        ENDIF
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYRVSB
C...Auxiliary function to PYRVSF for calculating R-Violating
C...sfermion widths. Though the decay products are most often treated
C...as massless in the calculation, the kinematical boundary of phase
C...space is tested using the true masses.
C...MODE = 1: All decay products massive
C...MODE = 2: Decay product 1 massless
C...MODE = 3: Decay product 2 massless
C...MODE = 4: All decay products  massless
 
      FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
 
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      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/
      DOUBLE PRECISION SM(3)
      INTEGER PYCOMP, KC(3)
      KC(1)=PYCOMP(KFIN)
      KC(2)=PYCOMP(ID1)
      KC(3)=PYCOMP(ID2)
      SM(1)=PMAS(KC(1),1)**2
      SM(2)=PMAS(KC(2),1)**2
      SM(3)=PMAS(KC(3),1)**2
C...Kinematics check
      IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
        PYRVSB=0D0
        RETURN
      ENDIF
C...CM momenta squared
      IF (MODE.EQ.1) THEN
        P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
     &       * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
      ELSE IF (MODE.EQ.2) THEN
        P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
      ELSE IF (MODE.EQ.3) THEN
        P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
      ELSE
        P2CM=SM(1)/4.
      ENDIF
C...Calculate Width
      PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
      RETURN
      END
 
C*********************************************************************
 
C...PYRVGW
C...Generalized Matrix Element for R-Violating 3-body widths.
C...P. Z. Skands
      SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
 
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
      PARAMETER (EPS=1D-4)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
      COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
     & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
      DOUBLE PRECISION XLIM(3,3)
      INTEGER KC(0:3), PYCOMP
      LOGICAL DCMASS, DCHECK(6)
      SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
 
      XLAM   = 0D0
 
      KC(0)  = PYCOMP(KFIN)
      KC(1)  = PYCOMP(ID1)
      KC(2)  = PYCOMP(ID2)
      KC(3)  = PYCOMP(ID3)
      RMS(0) = PMAS(KC(0),1)
      RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
      RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
      RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
      XLIM(1,1)=(RMS(1)+RMS(2))**2
      XLIM(1,2)=(RMS(0)-RMS(3))**2
      XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
      XLIM(2,1)=(RMS(2)+RMS(3))**2
      XLIM(2,2)=(RMS(0)-RMS(1))**2
      XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
      XLIM(3,1)=(RMS(1)+RMS(3))**2
      XLIM(3,2)=(RMS(0)-RMS(2))**2
      XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
C...Check Phase Space
      IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
        RETURN
      ENDIF
 
C...INITIALIZE RESONANCE INFORMATION
      DO 110 JRES = 1,3
        DO 100 IMASS = 1,2
          IRES = 2*(JRES-1)+IMASS
          INTRES(IRES,1) = 0
          DCHECK(IRES)   =.FALSE.
C...NO RIGHT-HANDED NEUTRINOS
          IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
     &         .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
     &         .KFR(JRES).EQ.0) GOTO 100
          RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
          RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
          INTRES(IRES,1) = IABS(KFR(JRES))
          INTRES(IRES,2) = IMASS
          IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
          IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
  100   CONTINUE
  110 CONTINUE
 
C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
 
C...RESONANCE CONTRIBUTIONS
C...(Only sum contributions where the resonance is off shell).
C...Store whether diagram on/off in DCHECK.
C...LOOP OVER MASS STATES
      DO 120 J=1,2
        IDR=J
        IF(INTRES(IDR,1).NE.0) THEN

        TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
        IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
     &       +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
          DCHECK(IDR) =.TRUE.
          XLAM = XLAM + TMIX * PYRVI1(2,3,1)
        ENDIF
        ENDIF
 
        IDR=J+2
        IF(INTRES(IDR,1).NE.0) THEN
        TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
        IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
     &       +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
          DCHECK(IDR) =.TRUE.
          XLAM = XLAM + TMIX * PYRVI1(1,3,2)
        ENDIF
        ENDIF
 
        IDR=J+4
        IF(INTRES(IDR,1).NE.0) THEN
        TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
        IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
     &       +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
          DCHECK(IDR) =.TRUE.
          XLAM = XLAM + TMIX * PYRVI1(1,2,3)
        ENDIF
        ENDIF
  120 CONTINUE
C... L-R INTERFERENCES
C... (Only add contributions where both contributing diagrams
C... are non-resonant).
      IDR=1
      IF (DCHECK(1).AND.DCHECK(2)) THEN
C...Bug corrected 11/12 2001. Skands.
        XLAM  = XLAM + 2D0 * PYRVI2(2,3,1)
     &     * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
     &     * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
      ENDIF
 
      IDR=3
      IF (DCHECK(3).AND.DCHECK(4)) THEN
        XLAM  = XLAM + 2D0 * PYRVI2(1,3,2)
     &     * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
     &     * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
      ENDIF
 
      IDR=5
      IF (DCHECK(5).AND.DCHECK(6)) THEN
        XLAM  = XLAM + 2D0 * PYRVI2(1,2,3)
     &     * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
     &     * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
      ENDIF
C... TRUE INTERFERENCES
C... (Only add contributions where both contributing diagrams
C... are non-resonant).
      PREF=-2D0
      IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
      DO 140 IKR1 = 1,2
        DO 130 IKR2 = 1,2
          IDR  = IKR1+2
          IDR2 = IKR2
          IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
            XLAM = XLAM + PREF*PYRVI3(1,3,2) *
     &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
     &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
          ENDIF
 
          IDR  = IKR1+4
          IDR2 = IKR2
          IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
            XLAM = XLAM + PREF*PYRVI3(1,2,3) *
     &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
     &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
          ENDIF
 
          IDR  = IKR1+4
          IDR2 = IKR2+2
          IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
            XLAM = XLAM + PREF*PYRVI3(2,1,3) *
     &           SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
     &           *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
          ENDIF
  130   CONTINUE
  140 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYRVI1
C...Function to integrate resonance contributions
 
      FUNCTION PYRVI1(ID1,ID2,ID3)
 
      IMPLICIT NONE
      DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
      DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
      INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
      LOGICAL MFLAG,DCMASS
      EXTERNAL PYRVG1,PYGAUS
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
      PYRVI1 = 0D0
      RM(0)  = RMS(0)
      RM(1)  = RMS(ID1)
      RM(2)  = RMS(ID2)
      RM(3)  = RMS(ID3)
      RESM(1)= RES(IDR,1)
      RESW(1)= RES(IDR,2)
C...A->B and B->A for antisparticles
      A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
      B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
C...Integration boundaries and mass flag
      LO     = (RM(1)+RM(2))**2
      HI     = (RM(0)-RM(3))**2
      MFLAG  = DCMASS
      PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
      RETURN
      END
 
C*********************************************************************
 
C...PYRVI2
C...Function to integrate L-R interference contributions
 
      FUNCTION PYRVI2(ID1,ID2,ID3)
 
      IMPLICIT NONE
      DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
      DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
      INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
      LOGICAL MFLAG,DCMASS
      EXTERNAL PYRVG2,PYGAUS
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
      PYRVI2 = 0D0
      RM(0)  = RMS(0)
      RM(1)  = RMS(ID1)
      RM(2)  = RMS(ID2)
      RM(3)  = RMS(ID3)
      RESM(1)= RES(IDR,1)
      RESW(1)= RES(IDR,2)
      RESM(2)= RES(IDR+1,1)
      RESW(2)= RES(IDR+1,2)
C...A->B and B->A for antisparticles
      A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
      B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
      A(2)   = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
      B(2)   = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
C...Boundaries and mass flag
      LO     = (RM(1)+RM(2))**2
      HI     = (RM(0)-RM(3))**2
      MFLAG  = DCMASS
      PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
      RETURN
      END
 
C*********************************************************************
 
C...PYRVI3
C...Function to integrate true interference contributions
 
      FUNCTION PYRVI3(ID1,ID2,ID3)
 
      IMPLICIT NONE
      DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
      DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
      INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
      LOGICAL MFLAG,DCMASS
      EXTERNAL PYRVG3,PYGAUS
      COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
     &     ,DCMASS,KFR(3)
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      SAVE/PYRVNV/,/PYRVPM/
C...Initialize mass and width information
      PYRVI3 = 0D0
      RM(0)  = RMS(0)
      RM(1)  = RMS(ID1)
      RM(2)  = RMS(ID2)
      RM(3)  = RMS(ID3)
      RESM(1)= RES(IDR,1)
      RESW(1)= RES(IDR,2)
      RESM(2)= RES(IDR2,1)
      RESW(2)= RES(IDR2,2)
C...A -> B and B -> A for antisparticles
      A(1)   = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
      B(1)   = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
      A(2)   = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
      B(2)   = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
C...Boundaries and mass flag
      LO     = (RM(1)+RM(2))**2
      HI     = (RM(0)-RM(3))**2
      MFLAG  = DCMASS
      PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
      RETURN
      END
 
C*********************************************************************
 
C...PYRVG1
C...Integrand for resonance contributions
 
      FUNCTION PYRVG1(X)
 
      IMPLICIT NONE
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
      DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
      LOGICAL MFLAG
      SAVE/PYRVPM/
      RVR    = PYRVR(X,RESM(1),RESW(1))
      C1     = 2D0*SQRT(MAX(0D0,X))
      IF (.NOT.MFLAG) THEN
        E2     = X/C1
        E3     = (RM(0)**2-X)/C1
        DELTAY = 4D0*E2*E3
        PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
      ELSE
        E2     = (X-RM(1)**2+RM(2)**2)/C1
        E3     = (RM(0)**2-X-RM(3)**2)/C1
        SR1    = SQRT(MAX(0D0,E2**2-RM(2)**2))
        SR2    = SQRT(MAX(0D0,E3**2-RM(3)**2))
        DELTAY = 4D0*SR1*SR2
        A1     = 4.*A(1)*B(1)*RM(3)*RM(0)
        A2     = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
        PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYRVG2
C...Integrand for L-R interference contributions
 
      FUNCTION PYRVG2(X)
 
      IMPLICIT NONE
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
      DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
      LOGICAL MFLAG
      SAVE/PYRVPM/
      C1     = 2D0*SQRT(MAX(0D0,X))
      RVS    = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
      IF (.NOT.MFLAG) THEN
        E2     = X/C1
        E3     = (RM(0)**2-X)/C1
        DELTAY = 4D0*E2*E3
        PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
      ELSE
        E2     = (X-RM(1)**2+RM(2)**2)/C1
        E3     = (RM(0)**2-X-RM(3)**2)/C1
        SR1    = SQRT(MAX(0D0,E2**2-RM(2)**2))
        SR2    = SQRT(MAX(0D0,E3**2-RM(3)**2))
        DELTAY = 4D0*SR1*SR2
        PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
     &       + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
     &       + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYRVG3
C...Function to do Y integration over true interference contributions
 
      FUNCTION PYRVG3(X)
 
      IMPLICIT NONE
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
C...Second Dalitz variable for PYRVG4
      COMMON/PYG2DX/X1
      DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
      DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
      DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
      LOGICAL MFLAG
      EXTERNAL PYGAU2,PYRVG4
      SAVE/PYRVPM/,/PYG2DX/
      PYRVG3=0D0
      C1=2D0*SQRT(MAX(1D-9,X))
      X1=X
      IF (.NOT.MFLAG) THEN
        E2    = X/C1
        E3    = (RM(0)**2-X)/C1
        YMIN  = 0D0
        YMAX  = 4D0*E2*E3
      ELSE
        E2    = (X-RM(1)**2+RM(2)**2)/C1
        E3    = (RM(0)**2-X-RM(3)**2)/C1
        SQ1   = (E2+E3)**2
        SR1   = SQRT(MAX(0D0,E2**2-RM(2)**2))
        SR2   = SQRT(MAX(0D0,E3**2-RM(3)**2))
        YMIN  = SQ1-(SR1+SR2)**2
        YMAX  = SQ1-(SR1-SR2)**2
      ENDIF
      PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
      RETURN
      END
 
C*********************************************************************
 
C...PYRVG4
C...Integrand for true intereference contributions
 
      FUNCTION PYRVG4(Y)
 
      IMPLICIT NONE
      COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
      COMMON/PYG2DX/X
      DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
      LOGICAL MFLAG
      SAVE /PYRVPM/,/PYG2DX/
      PYRVG4=0D0
      RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
      IF (.NOT.MFLAG) THEN
        PYRVG4 = RVS*B(1)*B(2)*X*Y
      ELSE
        PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
     &       + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
     &       + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
     &       + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
      ENDIF
      RETURN
      END
 
C*********************************************************************
 
C...PYRVR
C...Breit-Wigner for resonance contributions
 
      FUNCTION PYRVR(Mab2,RM,RW)
 
      IMPLICIT NONE
      DOUBLE PRECISION Mab2,RM,RW,PYRVR
      PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
      RETURN
      END
 
C*********************************************************************
 
C...PYRVS
C...Interference function
 
      FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
 
      IMPLICIT NONE
      DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
      PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
     &     +W1*W2*M1*M2)
      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).NE.12345) 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).NE.12345) 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).NE.12345) 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).NE.12345) 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)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
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...If colour reconnection then bookkeep W+W- or Z0Z0
C...and copy q qbar q qbar consecutively.
      IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
        K(N+1,1)=11
        K(N+1,3)=IP1
        K(N+1,4)=N+3
        K(N+1,5)=N+4
        K(N+2,1)=11
        K(N+2,3)=IP3
        K(N+2,4)=N+5
        K(N+2,5)=N+6
        IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
          K(N+1,2)=23
          K(N+2,2)=23
          MINT(1)=22
        ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
          K(N+1,2)=24
          K(N+2,2)=-24
          MINT(1)=25
        ELSE
          K(N+1,2)=-24
          K(N+2,2)=24
          MINT(1)=25
        ENDIF
        DO 110 J=1,5
          K(N+3,J)=K(IP1,J)
          K(N+4,J)=K(IP2,J)
          K(N+5,J)=K(IP3,J)
          K(N+6,J)=K(IP4,J)
          P(N+1,J)=P(IP1,J)+P(IP2,J)
          P(N+2,J)=P(IP3,J)+P(IP4,J)
          P(N+3,J)=P(IP1,J)
          P(N+4,J)=P(IP2,J)
          P(N+5,J)=P(IP3,J)
          P(N+6,J)=P(IP4,J)
          V(N+1,J)=V(IP1,J)
          V(N+2,J)=V(IP3,J)
          V(N+3,J)=V(IP1,J)
          V(N+4,J)=V(IP2,J)
          V(N+5,J)=V(IP3,J)
          V(N+6,J)=V(IP4,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))
        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...Remove original q qbar q qbar and update counters.
        K(IP1,1)=K(IP1,1)+10
        K(IP2,1)=K(IP2,1)+10
        K(IP3,1)=K(IP3,1)+10
        K(IP4,1)=K(IP4,1)+10
        IW1=N+1
        IW2=N+2
        NSD1=N+2
        IP1=N+3
        IP2=N+4
        IP3=N+5
        IP4=N+6
        N=N+6
      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
      NAFT1=N
      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...Optionally do colour reconnection.
      MINT(32)=0
      MSTI(32)=0
      IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
        CALL PYRECO(IW1,IW2,NSD1,NAFT1)
        MSTI(32)=MINT(32)
      ENDIF
 
C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 120 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
  120   CONTINUE
      ENDIF
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 130 I=1,NTAU
        K(INTAU(I),1)=1
  130   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,-100,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(8000,2),BRAT(8000),KFDP(8000,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)
      COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
      COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
      COMMON/PYPUED/IUED(0:99),RUED(0:99)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
     &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
     &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
C...Local arrays and character variables.
      CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
     &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
     &CHINR*16,CHDIG*10
      DIMENSION MSVAR(56,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','RVLAM','RVLAMP','RVLAMB',
     &'ITCM','RTCM','IUED','RUED'/
      DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 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,8000,1,2,2*0,
     &2,1,1,8000,4*0,  1,2,1,8000,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,
     &2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3,   2,3,1,3,1,3,1,3,
     &1,1,0,99,4*0,  2,1,0,99,4*0,  1,1,0,99,4*0,  2,1,0,99,4*0/
      DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
 
C...Length of character variable. Subdivide it into instructions.
      IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
     &CHIN.NE.'MSTU(12)=12345') 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...Send off decay-mode on/off commands to PYONOF.
      IONOF=0
      DO 135 LDIG=1,10
        IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
  135 CONTINUE
      IF(IONOF.EQ.1) THEN
        CALL PYONOF(CHIN)
        RETURN
      ENDIF   
 
C...Peel off any text following exclamation mark.
      LHIG2=LBIT
      DO 140 LLOW2=LHIG2,1,-1
        IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
  140 CONTINUE
      IF(LBIT.EQ.0) RETURN
 
C...Identify commonblock variable.
      LNAM=1
  150 LNAM=LNAM+1
      IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
     &LNAM.LE.6) GOTO 150
      CHNAM=CHBIT(1:LNAM-1)//' '
      DO 170 LCOM=1,LNAM-1
        DO 160 LALP=1,26
          IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
     &    CHALP(2)(LALP:LALP)
  160   CONTINUE
  170 CONTINUE
      IVAR=0
      DO 180 IV=1,56
        IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
  180 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
  190   LIND=LIND+1
        IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
        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.OR.
     &  IVAR.EQ.37)) 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
  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)') I2
        LNAM=LIND
        IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
        NINDX=2
      ENDIF
      IF(CHBIT(LNAM:LNAM).EQ.',') THEN
        LIND=LNAM
  210   LIND=LIND+1
        IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
        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)(1:8)
      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)
      ELSEIF(IVAR.EQ.50) THEN
        ROLD=RVLAM(I1,I2,I3)
      ELSEIF(IVAR.EQ.51) THEN
        ROLD=RVLAMP(I1,I2,I3)
      ELSEIF(IVAR.EQ.52) THEN
        ROLD=RVLAMB(I1,I2,I3)
      ELSEIF(IVAR.EQ.53) THEN
        IOLD=ITCM(I1)
      ELSEIF(IVAR.EQ.54) THEN
        ROLD=RTCM(I1)
      ELSEIF(IVAR.EQ.55) THEN
        IOLD=IUED(I1)
      ELSEIF(IVAR.EQ.56) THEN
        ROLD=RUED(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
      ELSEIF(IVAR.EQ.50) THEN
        RVLAM(I1,I2,I3)=RNEW
      ELSEIF(IVAR.EQ.51) THEN
        RVLAMP(I1,I2,I3)=RNEW
      ELSEIF(IVAR.EQ.52) THEN
        RVLAMB(I1,I2,I3)=RNEW
      ELSEIF(IVAR.EQ.53) THEN
        ITCM(I1)=INEW
      ELSEIF(IVAR.EQ.54) THEN
        RTCM(I1)=RNEW
      ELSEIF(IVAR.EQ.55) THEN
        IUED(I1)=INEW
      ELSEIF(IVAR.EQ.56) THEN
        RUED(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...PYONOF
C...Switches on and off decay channel by search for match.
 
      SUBROUTINE PYONOF(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/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      SAVE /PYDAT1/,/PYDAT3/
C...Local arrays and character variables.
      INTEGER KFCMP(10),KFTMP(10)
      CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
     &CHALP(2)*26
      DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
     &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/

C...Determine length of character variable.
      CHTMP=CHIN//' '
      LBEG=0
  100 LBEG=LBEG+1
      IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
      LEND=LBEG-1
  105 LEND=LEND+1
      IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
  110 LEND=LEND-1
      IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
      LEN=1+LEND-LBEG
      CHFIX(1:LEN)=CHTMP(LBEG:LEND)

C...Find colon separator and particle code.
      LCOLON=0
  120 LCOLON=LCOLON+1
      IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
      CHCODE=' '
      CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
      READ(CHCODE,'(I8)',ERR=300) KF
      KC=PYCOMP(KF)

C...Done if unknown code or no decay channels.
      IF(KC.EQ.0) THEN
        CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
        RETURN
      ENDIF
      IDCBEG=MDCY(KC,2)
      IDCLEN=MDCY(KC,3)
      IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
        CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
        RETURN
      ENDIF

C...Find command name up to blank or equal sign.
      LSEP=LCOLON
  130 LSEP=LSEP+1
      IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
     &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
      CHMODE=' '
      LMODE=LSEP-LCOLON-1
      CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)

C...Convert to uppercase.
      DO 150 LCOM=1,LMODE
        DO 140 LALP=1,26
          IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) 
     &    CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
  140   CONTINUE
  150 CONTINUE

C...Identify command. Failed if not identified.
      MODE=0
      IF(CHMODE.EQ.'ALLOFF') MODE=1
      IF(CHMODE.EQ.'ALLON') MODE=2
      IF(CHMODE.EQ.'OFFIFANY') MODE=3
      IF(CHMODE.EQ.'ONIFANY') MODE=4
      IF(CHMODE.EQ.'OFFIFALL') MODE=5
      IF(CHMODE.EQ.'ONIFALL') MODE=6
      IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
      IF(CHMODE.EQ.'ONIFMATCH') MODE=8
      IF(MODE.EQ.0) THEN
        CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
        RETURN
      ENDIF

C...Simple cases when all on or all off.
      IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
        WRITE(MSTU(11),1000) KF,CHMODE
        DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
          IF(MDME(IDC,1).LT.0) GOTO 160
          MDME(IDC,1)=MODE-1
  160   CONTINUE
        RETURN
      ENDIF

C...Identify matching list.
      NCMP=0
      LBEG=LSEP
  170 LBEG=LBEG+1
      IF(LBEG.GT.LEN) GOTO 190
      IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
     &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
      LEND=LBEG-1
  180 LEND=LEND+1
      IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
     &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
      IF(LEND.LT.LEN) LEND=LEND-1
      CHCODE=' '
      CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
      READ(CHCODE,'(I8)',ERR=300) KFREAD
      NCMP=NCMP+1
      KFCMP(NCMP)=IABS(KFREAD)
      LBEG=LEND
      IF(NCMP.LT.10) GOTO 170
  190 CONTINUE
      WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)

C...Only one matching required.
      IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
        DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
          IF(MDME(IDC,1).LT.0) GOTO 220
          DO 210 IKF=1,5
            KFNOW=IABS(KFDP(IDC,IKF))
            IF(KFNOW.EQ.0) GOTO 210
            DO 200 ICMP=1,NCMP
              IF(KFCMP(ICMP).EQ.KFNOW) THEN
                MDME(IDC,1)=MODE-3
                GOTO 220
              ENDIF
  200      CONTINUE
  210     CONTINUE
  220   CONTINUE
        RETURN
      ENDIF

C...Multiple matchings required.
      DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
        IF(MDME(IDC,1).LT.0) GOTO 260
        NTMP=NCMP
        DO 230 ITMP=1,NTMP
          KFTMP(ITMP)=KFCMP(ITMP)
  230   CONTINUE  
        NFIN=0 
        DO 250 IKF=1,5
          KFNOW=IABS(KFDP(IDC,IKF))
          IF(KFNOW.EQ.0) GOTO 250
          NFIN=NFIN+1
          DO 240 ITMP=1,NTMP
            IF(KFTMP(ITMP).EQ.KFNOW) THEN
              KFTMP(ITMP)=KFTMP(NTMP) 
              NTMP=NTMP-1
              GOTO 250
            ENDIF
  240     CONTINUE
  250   CONTINUE
        IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
        IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7) 
     &  MDME(IDC,1)=MODE-7
  260 CONTINUE
      RETURN

C...Error exit for impossible read of particle code.
  300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
     &//CHCODE)

C...Formats for output.
 1000 FORMAT(' Decays for',I8,' set ',A10)
 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)

      RETURN
      END
C*********************************************************************
 
C...PYTUNE
C...Presets for a few specific underlying-event and min-bias tunes
C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
C...others require particular versions of pythia (e.g. the SCI and GAL
C...models). See below for details.
      SUBROUTINE PYTUNE(ITUNE)
C
C ITUNE    NAME (detailed descriptions below)
C     0 Default : No settings changed => defaults.
C
C ====== Old UE, Q2-ordered showers ====================================
C   100       A : Rick Field's CDF Tune A                     (Oct 2002)
C   101      AW : Rick Field's CDF Tune AW                    (Apr 2006)
C   102      BW : Rick Field's CDF Tune BW                    (Apr 2006)
C   103      DW : Rick Field's CDF Tune DW                    (Apr 2006)
C   104     DWT : As DW but with slower UE ECM-scaling        (Apr 2006)
C   105      QW : Rick Field's CDF Tune QW using CTEQ6.1M            (?)
C   106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome")          (?)
C   107     ACR : Tune A modified with new CR model           (Mar 2007)
C   108      D6 : Rick Field's CDF Tune D6 using CTEQ6L1             (?)
C   109     D6T : Rick Field's CDF Tune D6T using CTEQ6L1            (?)
C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
C   110   A-Pro : Tune A, with LEP tune from Professor        (Oct 2008)
C   111  AW-Pro : Tune AW, -"-                                (Oct 2008)
C   112  BW-Pro : Tune BW, -"-                                (Oct 2008)
C   113  DW-Pro : Tune DW, -"-                                (Oct 2008)
C   114 DWT-Pro : Tune DWT, -"-                               (Oct 2008)
C   115  QW-Pro : Tune QW, -"-                                (Oct 2008)
C   116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"-                  (Oct 2008)
C   117 ACR-Pro : Tune ACR, -"-                               (Oct 2008)
C   118  D6-Pro : Tune D6, -"-                                (Oct 2008)
C   119 D6T-Pro : Tune D6T, -"-                               (Oct 2008)
C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
C   129 Pro-Q20 : Professor Q2-ordered tune                   (Feb 2009)
C
C ====== Intermediate and Hybrid Models ================================
C   200    IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
C   201     APT : Tune A w. pT-ordered FSR                    (Mar 2007)
C   211 APT-Pro : Tune APT, with LEP tune from Professor      (Oct 2008)
C   221 Perugia APT  : "Perugia" update of APT-Pro            (Feb 2009)
C   226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
C
C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
C   300      S0 : Sandhoff-Skands Tune using the S0 CR model  (Apr 2006)
C   301      S1 : Sandhoff-Skands Tune using the S1 CR model  (Apr 2006)
C   302      S2 : Sandhoff-Skands Tune using the S2 CR model  (Apr 2006)
C   303     S0A : S0 with "Tune A" UE energy scaling          (Apr 2006)
C   304    NOCR : New UE "best try" without col. rec.         (Apr 2006)
C   305     Old : New UE, original (primitive) col. rec.      (Aug 2004)
C   306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
C   310   S0-Pro : S0 with updated LEP pars from Professor    (Oct 2008)
C   311   S1-Pro : S1 -"-                                     (Oct 2008)
C   312   S2-Pro : S2 -"-                                     (Oct 2008)
C   313  S0A-Pro : S0A -"-                                    (Oct 2008)
C   314 NOCR-Pro : NOCR -"-                                   (Oct 2008)
C   315  Old-Pro : Old -"-                                    (Oct 2008)
C ---- Peter's Perugia Tunes : 320+ ------------------------------------
C   320 Perugia 0 : "Perugia" update of S0-Pro                (Feb 2009)
C   321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
C   322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
C   323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
C                   balance & different scaling to LHC & RHIC (Feb 2009)
C   324 Perugia NOCR : "Perugia" update of NOCR-Pro           (Feb 2009)
C   325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
C   326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
C   329 Pro-pT0   : Professor pT-ordered tune w. S0 CR model  (Feb 2009)
C
C ======= The Uppsala models ===========================================
C   ( NB! must be run with special modified Pythia 6.215 version )
C   ( available from http://www.isv.uu.se/thep/MC/scigal/        )
C   400   GAL 0 : Generalized area-law model. Org pars        (Dec 1998)
C   401   SCI 0 : Soft-Colour-Interaction model. Org pars     (Dec 1998)
C   402   GAL 1 : GAL 0. Tevatron MB retuned (Skands)         (Oct 2006)
C   403   SCI 1 : SCI 0. Tevatron MB retuned (Skands)         (Oct 2006)
C
C More details;
C
C Quick Dictionary:
C      BE : Bose-Einstein
C      BR : Beam Remnants
C      CR : Colour Reconnections
C      HAD: Hadronization
C      ISR/FSR: Initial-State Radiation / Final-State Radiation
C      FSI: Final-State Interactions (=CR+BE)
C      MB : Minimum-bias
C      MI : Multiple Interactions
C      UE : Underlying Event
C
C=======================================================================
C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
C=======================================================================
C
C   A (100) and AW (101). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...* Large starting scale for ISR (PARP(67)=4)
C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C   BW (102). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...NB: Can also be run with Pythia 6.2 or 6.312+
C...* Small starting scale for ISR (PARP(67)=1)
C...* BW has more radiation due to smaller mu_R choice in alpha_s.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C   DW (103) and DWT (104). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: extensively compared to CDF data (R.D. Field).
C...NB: Can also be run with Pythia 6.2 or 6.312+
C...* Intermediate starting scale for ISR (PARP(67)=2.5)
C...* DWT has a different reference energy, the same as the "S" models
C...  below, leading to more UE activity at the LHC, but less at RHIC.
C...* See: http://www.phys.ufl.edu/~rfield/cdf/
C
C   QW (105). CTEQ61 parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: uses CTEQ61 (external pdf library must be linked)
C
C   ATLAS-DC2 (106). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
C...***      CAN ALSO BE RUN WITH PYTHIA 6.406+
C...Key feature: tune used by the ATLAS collaboration.
C
C   ACR (107). CTEQ5L parton distributions
C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+    ***
C...Key feature: Tune A modified to use annealing CR.
C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
C
C   D6 (108) and D6T (109). CTEQ6L parton distributions
C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
C
C   A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
C   Old UE model, Q2-ordered showers.
C...Key feature: Rick Field's family of tunes revamped with the
C...Professor Q2-ordered final-state shower and fragmentation tunes
C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
C...Key feature: improved descriptions of LEP data.
C
C   Pro-Q20 (129). CTEQ5L parton distributions
C   Old UE model, Q2-ordered showers.
C...Key feature: Complete retune of old model by Professor, including
C...large amounts of both LEP and Tevatron data.
C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
C...extreme in this tune, corresponding to using mu_R = pT/3 .
C
C=======================================================================
C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
C=======================================================================
C
C   IM1 (200). Intermediate model, Q2-ordered showers,
C   CTEQ5L parton distributions
C...Key feature: new UE model w Q2-ordered showers and no interleaving.
C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
C
C   APT (201). Old UE model, pT-ordered final-state showers,
C   CTEQ5L parton distributions
C...Key feature: Rick Field's Tune A, but with new final-state showers
C
C   APT-Pro (211). Old UE model, pT-ordered final-state showers,
C   CTEQ5L parton distributions
C...Key feature: APT revamped with the Professor pT-ordered final-state
C...shower and fragmentation tunes presented by Hendrik Hoeth at the
C...Perugia MPI workshop in October 2008.
C
C   Perugia-APT (221). Old UE model, pT-ordered final-state showers,
C   CTEQ5L parton distributions
C...Key feature: APT-Pro with final-state showers off the MPI,
C...lower ISR renormalization scale to improve agreement with the
C...Tevatron Drell-Yan pT measurements and with improved energy scaling
C...to min-bias at 630 GeV.
C
C   Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
C   CTEQ6L1 parton distributions.
C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
C
C=======================================================================
C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
C=======================================================================
C
C   S0 (300) and S0A (303). CTEQ5L parton distributions
C...Key feature: large amount of multiple interactions
C...* Somewhat faster than the other colour annealing scenarios.
C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
C...  from Tune A, leading to less UE at the LHC, but more at RHIC.
C...* Small amount of radiation.
C...* Large amount of low-pT MI
C...* Low degree of proton lumpiness (broad matter dist.)
C...* CR Type S (driven by free triplets), of medium strength.
C...* See: Pythia6402 update notes or later.
C
C   S1 (301). CTEQ5L parton distributions
C...Key feature: large amount of radiation.
C...* Large amount of low-pT perturbative ISR
C...* Large amount of FSR off ISR partons
C...* Small amount of low-pT multiple interactions
C...* Moderate degree of proton lumpiness
C...* Least aggressive CR type (S+S Type I), but with large strength
C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
C
C   S2 (302). CTEQ5L parton distributions
C...Key feature: very lumpy proton + gg string cluster formation allowed
C...* Small amount of radiation
C...* Moderate amount of low-pT MI
C...* High degree of proton lumpiness (more spiky matter distribution)
C...* Most aggressive CR type (S+S Type II), but with small strength
C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
C
C   NOCR (304). CTEQ5L parton distributions
C...Key feature: no colour reconnections (NB: "Best fit" only).
C...* NB: <pT>(Nch) problematic in this tune.
C...* Small amount of radiation
C...* Small amount of low-pT MI
C...* Low degree of proton lumpiness
C...* Large BR composite x enhancement factor
C...* Most clever colour flow without CR ("Lambda ordering")
C
C   ATLAS-CSC (306). CTEQ6L parton distributions
C...Key feature: 11-parameter ATLAS tune of the new framework.
C...* Old (pre-annealing) colour reconnections a la 305.
C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
C
C   S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
C...Key feature: the S0 family of tunes revamped with the Professor
C...pT-ordered final-state shower and fragmentation tunes presented by
C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
C...Key feature: improved descriptions of LEP data.
C
C   Perugia-0 (320). CTEQ5L parton distributions.
C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
C...beam-remnant breakup (more baryon number transport), and suppression
C...of CR in high-pT string pieces.
C
C   Perugia-HARD (321). CTEQ5L parton distributions.
C...Key feature: More ISR, More FSR, Less MPI, Less BR
C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
C...baryon number transport), and more fragmentation pT.
C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
C...DY pT spectrum is HARD.
C
C   Perugia-SOFT (322). CTEQ5L parton distributions.
C...Key feature: Less ISR, Less FSR, More MPI, More BR
C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
C...number transport), and less fragmentation pT.
C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
C...DY pT spectrum is SOFT
C
C   Perugia-3 (323). CTEQ5L parton distributions.
C...Key feature: variant of Perugia-0 with more extreme energy scaling
C...properties while still agreeing with Tevatron data from 630 to 1960.
C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
C...allows FSR off the active end of dipoles stretched to the remnant.
C
C   Perugia-NOCR (324). CTEQ5L parton distributions.
C...Key feature: Retune of NOCR-Pro with better scaling properties to
C...lower energies and somewhat better agreement with Tevatron data
C...at 1800/1960.
C
C   Perugia-* (325). MRST LO* parton distributions for generators
C...Key feature: first attempt at using the LO* distributions
C...(external pdf library must be linked).
C
C   Perugia-6 (326). CTEQ6L1 parton distributions
C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
C
C   Pro-pT0 (329). CTEQ5L parton distributions
C...Key feature: Complete retune of new model by Professor, including
C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
C
C=======================================================================
C OTHER TUNES
C=======================================================================
C
C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
C...with an unmodified Pythia distribution.
C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
C
C ::: + Future improvements?
C        Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
C       (problem: K-factor affects everything so only works as
C        intended for min-bias, not for UE ... probably need a
C        better long-term solution to handle UE as well. Anyway,
C        Mark uses MSTP(33) and PARP(31)-PARP(33).)
 
C...Global statements
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      INTEGER PYK,PYCHGE,PYCOMP
 
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
 
C...SCI and GAL Commonblocks
      COMMON /SCIPAR/MSWI(2),PARSCI(2)
 
C...SAVE statements
      SAVE /PYDAT1/,/PYPARS/
      SAVE /SCIPAR/

C...Internal parameters
      PARAMETER(MXTUNS=500)
      CHARACTER*8 CHVERS, CHDOC
      PARAMETER (CHVERS='1.015   ',CHDOC='Jan 2009')
      CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
      CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
     &    CHPARJ(1:100), CH40
      CHARACTER*60 CH60
      CHARACTER*70 CH70
      DATA (CHNAMS(I),I=0,1)/'Default',' '/
      DATA (CHNAMS(I),I=100,119)/
     &    'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
     &    'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
     1    'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
     1    'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
     1    'Tune D6-Pro','Tune D6T-Pro'/
      DATA (CHNAMS(I),I=120,129)/
     &     9*' ','Pro-Q20'/
      DATA (CHNAMS(I),I=300,309)/
     &    'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
     5    'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
      DATA (CHNAMS(I),I=310,315)/
     &    'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
     &    'NOCR-Pro','Old-Pro'/
      DATA (CHNAMS(I),I=320,329)/
     &    'Perugia 0','Perugia HARD','Perugia SOFT',
     &    'Perugia 3','Perugia NOCR','Perugia LO*',
     &    'Perugia 6',2*' ','Pro-pT0'/
      DATA (CHNAMS(I),I=200,229)/
     &    'IM Tune 1','Tune APT',8*' ',
     &    ' ','Tune APT-Pro',8*' ',
     &    ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
      DATA (CHNAMS(I),I=400,409)/
     &    'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
      DATA (CHMSTJ(I),I=11,20)/
     &    'HAD choice of fragmentation function(s)',4*' ',
     &    'HAD treatment of small-mass systems',4*' '/
      DATA (CHMSTJ(I),I=41,50)/
     &    'FSR type (Q2 or pT) for old framework',9*' '/
      DATA (CHMSTP(I),I=51,100)/
     5    'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
     6    'ISR master switch',2*' ','ISR alphaS type',2*' ',
     6    'ISR coherence option for 1st emission',
     6    'ISR phase space choice & ME corrections',' ',
     7    'ISR IR regularization scheme',' ',
     7    'ISR scheme for FSR off ISR',8*' ',
     8    'UE model',
     8    'UE hadron transverse mass distribution',5*' ',
     8    'BR composite scheme','BR colour scheme',
     9    'BR primordial kT compensation',
     9    'BR primordial kT distribution',
     9    'BR energy partitioning scheme',2*' ',
     9    'FSI colour (re-)connection model',5*' '/
      DATA (CHPARP(I),I=61,100)/
     6    ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
     6    2*' ','ISR Q2max factor',3*' ',
     7    'FSR Q2max factor for non-s-channel procs',5*' ',
     7    'FSI colour reco high-pT dampening strength',
     7    'FSI colour reconnection strength',
     7    'BR composite x enhancement','BR breakup suppression',
     8    2*'UE IR cutoff at reference ecm',
     8    2*'UE mass distribution parameter',
     8    'UE gg colour correlated fraction','UE total gg fraction',
     8    2*' ',
     8    'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
     9    'BR primordial kT width <|kT|>',' ',
     9    'BR primordial kT UV cutoff',7*' '/
      DATA (CHPARJ(I),I=1,30)/
     &    'HAD diquark suppression','HAD strangeness suppression',
     &    'HAD strange diquark suppression',
     &    'HAD vector diquark suppression',6*' ',
     1    'HAD P(vector meson), u and d only',
     1    'HAD P(vector meson), contains s',
     1    'HAD P(vector meson), heavy quarks',7*' ',
     2    'HAD fragmentation pT',' ',' ',' ',
     2    'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
      DATA (CHPARJ(I),I=41,90)/
     4    'HAD string parameter a','HAD string parameter b',3*' ',
     4    'HAD Lund(=0)-Bowler(=1) rQ (rc)',
     4    'HAD Lund(=0)-Bowler(=1) rb',3*' ',
     5    3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
     6    10*' ',10*' ',
     8    'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
 
C...1) Shorthand notation
      M13=MSTU(13)
      M11=MSTU(11)
      IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
        CHNAME=CHNAMS(ITUNE)
        IF (ITUNE.EQ.0) GOTO 9999
      ELSE
        CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
        GOTO 9999
      ENDIF
 
C...2) Hello World
      IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
 
C...3) Tune parameters
 
C=======================================================================
C...S0, S1, S2, S0A, NOCR, Rap,
C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
C...Pro-pT0
      IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
     &    .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
     &    .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
        IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
        IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune.')
        ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
     &        (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
     &        THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune.')
        ENDIF
 
C...Use Professor's LEP pars if ITUNE >= 310
C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
        IF (ITUNE.LT.310) THEN
C...# Old default flavour parameters
 
        ELSEIF (ITUNE.GE.310) THEN
C...# Tuned flavour parameters:
          PARJ(1)  = 0.073
          PARJ(2)  = 0.2
          PARJ(3)  = 0.94
          PARJ(4)  = 0.032
          PARJ(11) = 0.31
          PARJ(12) = 0.4
          PARJ(13) = 0.54
          PARJ(25) = 0.63
          PARJ(26) = 0.12
C...# Always use pT-ordered shower:
          MSTJ(41) = 12
C...# Switch on Bowler:
          MSTJ(11) = 5
C...# Fragmentation
          PARJ(21) = 0.313
          PARJ(41) = 0.49
          PARJ(42) = 1.2
          PARJ(47) = 1.0
          PARJ(81) = 0.257
          PARJ(82) = 0.8
        ENDIF
 
C...Remove middle digit now for Professor variants, since identical pars
        ITUNEB=ITUNE
        IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
          ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
        ENDIF
 
C...PDFs: all use CTEQ5L as starting point
        MSTP(52)=1
        MSTP(51)=7
        IF (ITUNE.EQ.325) THEN
C...MRST LO* for 325
          MSTP(52)=2
          MSTP(51)=20650
        ELSEIF (ITUNE.EQ.326) THEN
C...CTEQ6L1 for 326
          MSTP(52)=2
          MSTP(51)=10042
        ENDIF
 
C...ISR: use Lambda_MSbar with default scale for S0(A)
        MSTP(64)=2
        PARP(64)=1D0
        IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
     &      ITUNE.EQ.326) THEN
C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
          MSTP(64)=3
          PARP(64)=1D0
        ELSEIF (ITUNE.EQ.321) THEN
C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
          MSTP(64)=3
          PARP(64)=0.25D0
        ELSEIF (ITUNE.EQ.322) THEN
C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
          MSTP(64)=2
          PARP(64)=2D0
        ELSEIF (ITUNE.EQ.325) THEN
C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
          MSTP(64)=3
          PARP(64)=2D0
        ELSEIF (ITUNE.EQ.329) THEN
C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
          MSTP(64)=2
          PARP(64)=1.3D0
        ENDIF
 
C...ISR : power-suppressed power showers above s_color (since 6.4.19)
        MSTP(67)=2
        PARP(67)=4D0
C...Perugia tunes have stronger suppression, except HARD
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
          PARP(67)=1D0
          IF (ITUNE.EQ.321) PARP(67)=4D0
          IF (ITUNE.EQ.322) PARP(67)=0.5D0
        ENDIF
 
C...ISR IR cutoff type and FSR off ISR setting:
C...Smooth ISR, low FSR-off-ISR
        MSTP(70)=2
        MSTP(72)=0
        IF (ITUNEB.EQ.301) THEN
C...S1, S1-Pro: sharp ISR, high FSR
          MSTP(70)=0
          MSTP(72)=1
        ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
     &        .OR.ITUNE.EQ.325) THEN
C...Perugia default is smooth ISR, high FSR-off-ISR
          MSTP(70)=2
          MSTP(72)=1
        ELSEIF (ITUNE.EQ.321) THEN
C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
          MSTP(70)=0
          PARP(62)=1.25D0
          MSTP(72)=1
        ELSEIF (ITUNE.EQ.322) THEN
C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
          MSTP(70)=1
          PARP(81)=1.5D0
          MSTP(72)=0
        ELSEIF (ITUNE.EQ.323) THEN
C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
          MSTP(70)=0
          PARP(62)=1.25D0
          MSTP(72)=2
        ENDIF
 
C...FSR activity: Perugia tunes use a lower PARP(71) as indicated 
C...by Professor tunes (with HARD and SOFT variations)
        PARP(71)=4D0
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN 
          PARP(71)=2D0
          IF (ITUNE.EQ.321) PARP(71)=4D0
          IF (ITUNE.EQ.322) PARP(71)=1D0
        ENDIF

C...FSR: Lambda_FSR scale (only if not using professor)
        IF (ITUNE.LT.310) PARJ(81)=0.23D0
        IF (ITUNE.EQ.321) PARJ(81)=0.30D0
        IF (ITUNE.EQ.322) PARJ(81)=0.20D0
 
C...UE on, new model
        MSTP(81)=21
 
C...UE: hadron-hadron overlap profile (expOfPow for all)
        MSTP(82)=5
C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
        PARP(83)=1.6D0
        IF (ITUNEB.EQ.301) PARP(83)=1.4D0
        IF (ITUNEB.EQ.302) PARP(83)=1.2D0
C...NOCR variants have very smooth distributions
        IF (ITUNEB.EQ.304) PARP(83)=1.8D0
        IF (ITUNEB.EQ.305) PARP(83)=2.0D0
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
C...Perugia variants have slightly smoother profiles by default
C...(to compensate for more tail by added radiation)
C...Perugia-SOFT has more peaked distribution, NOCR less peaked
          PARP(83)=1.7D0
          IF (ITUNE.EQ.322) PARP(83)=1.5D0
          IF (ITUNE.EQ.324) PARP(83)=1.8D0
        ENDIF
C...Professor-pT0 also has very smooth distribution
        IF (ITUNE.EQ.329) PARP(83)=1.8
 
C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
        PARP(82)=1.85D0
        IF (ITUNEB.EQ.301) PARP(82)=2.1D0
        IF (ITUNEB.EQ.302) PARP(82)=1.9D0
        IF (ITUNEB.EQ.304) PARP(82)=2.05D0
        IF (ITUNEB.EQ.305) PARP(82)=1.9D0
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
C...slightly higher, due to increased activity.
          PARP(82)=2.0D0
          IF (ITUNE.EQ.321) PARP(82)=2.3D0
          IF (ITUNE.EQ.322) PARP(82)=1.9D0
          IF (ITUNE.EQ.323) PARP(82)=2.2D0
          IF (ITUNE.EQ.324) PARP(82)=1.95D0
          IF (ITUNE.EQ.325) PARP(82)=2.2D0
          IF (ITUNE.EQ.326) PARP(82)=1.95D0
        ENDIF
C...Professor-pT0 maintains low pT0 vaue
        IF (ITUNE.EQ.329) PARP(82)=1.85D0
 
C...UE: IR cutoff reference energy and default energy scaling pace
        PARP(89)=1800D0
        PARP(90)=0.16D0
C...S0A, S0A-Pro have tune A energy scaling
        IF (ITUNEB.EQ.303) PARP(90)=0.25D0
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
C...Perugia tunes explicitly include MB at 630 to fix energy scaling
          PARP(90)=0.26
          IF (ITUNE.EQ.321) PARP(90)=0.30D0
          IF (ITUNE.EQ.322) PARP(90)=0.24D0
          IF (ITUNE.EQ.323) PARP(90)=0.32D0
          IF (ITUNE.EQ.324) PARP(90)=0.24D0
C...LO* and CTEQ6L1 tunes have slower energy scaling
          IF (ITUNE.EQ.325) PARP(90)=0.23D0
          IF (ITUNE.EQ.326) PARP(90)=0.22D0
        ENDIF
C...Professor-pT0 has intermediate scaling
        IF (ITUNE.EQ.329) PARP(90)=0.22D0
 
C...BR: MPI initiator color connections rap-ordered by default
C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
        MSTP(89)=1
        IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
        IF (ITUNE.EQ.322) MSTP(89)=0
 
C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
        PARP(80)=0.01D0
        IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
C...Perugia tunes have more beam blowup by default
          PARP(80)=0.05D0
          IF (ITUNE.EQ.321) PARP(80)=0.01
          IF (ITUNE.EQ.323) PARP(80)=0.03
          IF (ITUNE.EQ.324) PARP(80)=0.01
        ENDIF
 
C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
        MSTP(88)=0
        PARP(79)=2D0
        IF (ITUNEB.EQ.304) PARP(79)=3D0
        IF (ITUNE.EQ.329) PARP(79)=1.18
 
C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
        MSTP(91)=1
        PARP(91)=2D0
        PARP(93)=10D0
C...Perugia-HARD only uses 1.0 GeV
        IF (ITUNE.EQ.321) PARP(91)=1.0D0
C...Perugia-3 only uses 1.5 GeV
        IF (ITUNE.EQ.323) PARP(91)=1.5D0
C...Professor-pT0 uses 7-GeV cutoff
        IF (ITUNE.EQ.329) PARP(93)=7.0
 
C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
        MSTP(95)=6
C...S1, S1-Pro: use S1
        IF (ITUNEB.EQ.301) MSTP(95)=2
C...S2, S2-Pro: use S2
        IF (ITUNEB.EQ.302) MSTP(95)=4
C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
        IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
C..."Old" and "Old"-Pro: use old CR
        IF (ITUNEB.EQ.305) MSTP(95)=1
 
C...FSI: CR strength and high-pT dampening, default is S0
        IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
          PARP(78)=0.2D0
          PARP(77)=0D0
          IF (ITUNEB.EQ.301) PARP(78)=0.35D0
          IF (ITUNEB.EQ.302) PARP(78)=0.15D0
          IF (ITUNEB.EQ.304) PARP(78)=0.0D0
          IF (ITUNEB.EQ.305) PARP(78)=1.0D0
          IF (ITUNE.EQ.329) PARP(78)=0.17D0
        ELSE
C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
          PARP(78)=0.33
          PARP(77)=0.9D0
          IF (ITUNE.EQ.321) THEN
C...HARD has HIGH amount of CR
            PARP(78)=0.37D0
            PARP(77)=0.4D0
          ELSEIF (ITUNE.EQ.322) THEN
C...SOFT has LOW amount of CR
            PARP(78)=0.15D0
            PARP(77)=0.5D0
          ELSEIF (ITUNE.EQ.323) THEN
C...Scaling variant appears to need slightly more than default
            PARP(78)=0.35D0
            PARP(77)=0.6D0
          ELSEIF (ITUNE.EQ.324) THEN
C...NOCR has no CR
            PARP(78)=0D0
            PARP(77)=0D0
          ENDIF
        ENDIF
 
C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
        IF (ITUNE.EQ.321) PARJ(21)=0.34D0
        IF (ITUNE.EQ.322) PARJ(21)=0.28D0
 
C...Switch off trial joinings
        MSTP(96)=0
 
C...S0 (300), S0A (303)
        IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
          IF (M13.GE.1) THEN
            CH60='see P. Skands & D. Wicke, hep-ph/0703081'
            WRITE(M11,5030) CH60
            CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            IF (ITUNE.GE.310) THEN
              CH60='LEP parameters tuned by Professor'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C...S1 (301)
        ELSEIF(ITUNEB.EQ.301) THEN
          IF (M13.GE.1) THEN
            CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            IF (ITUNE.GE.310) THEN
              CH60='LEP parameters tuned with Professor'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C...S2 (302)
        ELSEIF(ITUNEB.EQ.302) THEN
          IF (M13.GE.1) THEN
            CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            IF (ITUNE.GE.310) THEN
              CH60='LEP parameters tuned by Professor'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C...NOCR (304)
        ELSEIF(ITUNEB.EQ.304) THEN
          IF (M13.GE.1) THEN
            CH60='"best try" without colour reconnections'
            WRITE(M11,5030) CH60
            CH60='see P. Skands & D. Wicke, hep-ph/0703081'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            IF (ITUNE.GE.310) THEN
              CH60='LEP parameters tuned by Professor'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C..."Lo FSR" retune (305)
        ELSEIF(ITUNEB.EQ.305) THEN
          IF (M13.GE.1) THEN
            CH60='"Lo FSR retune" with primitive colour reconnections'
            WRITE(M11,5030) CH60
            CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            IF (ITUNE.GE.310) THEN
              CH60='LEP parameters tuned by Professor'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C...Perugia Tunes (320-326)
        ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
          IF (M13.GE.1) THEN
            CH60='P. Skands, Perugia MPI workshop October 2008'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
            WRITE(M11,5030) CH60
            CH60='LEP parameters tuned by Professor'
            WRITE(M11,5030) CH60
            IF (ITUNE.EQ.325) THEN
              CH70='NB! This tune requires MRST LO* pdfs to be '//
     &            'externally linked'
              WRITE(M11,5035) CH70
            ELSEIF (ITUNE.EQ.326) THEN
              CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
     &            'externally linked'
              WRITE(M11,5035) CH70
            ELSEIF (ITUNE.EQ.321) THEN
              CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
              WRITE(M11,5030) CH60
            ELSEIF (ITUNE.EQ.322) THEN
              CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
              WRITE(M11,5030) CH60
            ENDIF
          ENDIF
 
C...Professor-pT0 (329)
        ELSEIF(ITUNE.EQ.329) THEN
          IF (M13.GE.1) THEN
            CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
            WRITE(M11,5030) CH60
            CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
            WRITE(M11,5030) CH60
            CH60='LEP/Tevatron parameters tuned by Professor'
            WRITE(M11,5030) CH60
          ENDIF
 
        ENDIF
 
C...Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          IF (MSTP(70).EQ.0) THEN
            WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          ELSEIF (MSTP(70).EQ.1) THEN
            WRITE(M11,5050) 81, PARP(81), CHPARP(62)
            CH60='(Note: PARP(81) replaces PARP(62).)'
            WRITE(M11,5030) CH60
          ENDIF
          WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
          WRITE(M11,5050) 67, PARP(67), CHPARP(67)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
          WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          IF (MSTP(70).EQ.2) THEN
            CH60='(Note: PARP(82) replaces PARP(62).)'
            WRITE(M11,5030) CH60
          ENDIF
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
          WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
          WRITE(M11,5050) 79, PARP(79), CHPARP(79)
          WRITE(M11,5050) 80, PARP(80), CHPARP(80)
          WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
          WRITE(M11,5050) 91, PARP(91), CHPARP(91)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
          IF (MSTP(95).GE.1) THEN
            WRITE(M11,5050) 78, PARP(78), CHPARP(78)
            IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
          ENDIF
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C=======================================================================
C...ATLAS-CSC 11-parameter tune (By A. Moraes)
      ELSEIF (ITUNE.EQ.306) THEN
        IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
        IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune.')
        ENDIF
 
C...PDFs
        MSTP(52)=2
        MSTP(54)=2
        MSTP(51)=10042
        MSTP(53)=10042
C...ISR
C        PARP(64)=1D0
C...UE on, new model.
        MSTP(81)=21
C...Energy scaling
        PARP(89)=1800D0
        PARP(90)=0.22D0
C...Switch off trial joinings
        MSTP(96)=0
C...Primordial kT cutoff
 
        IF (M13.GE.1) THEN
          CH60='see presentations by A. Moraes (ATLAS),'
          WRITE(M11,5030) CH60
          CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
          WRITE(M11,5030) CH60
          WRITE(M11,5030) ' '
          CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
     &        'externally linked'
          WRITE(M11,5035) CH70
        ENDIF
C...Smooth ISR, low FSR
        MSTP(70)=2
        MSTP(72)=0
C...pT0
        PARP(82)=1.9D0
C...Transverse density profile.
        MSTP(82)=4
        PARP(83)=0.3D0
        PARP(84)=0.5D0
C...ISR & FSR in interactions after the first (default)
        MSTP(84)=1
        MSTP(85)=1
C...No double-counting (default)
        MSTP(86)=2
C...Companion quark parent gluon (1-x) power
        MSTP(87)=4
C...Primordial kT compensation along chaings (default = 0 : uniform)
        MSTP(90)=1
C...Colour Reconnections
        MSTP(95)=1
        PARP(78)=0.2D0
C...Lambda_FSR scale.
        PARJ(81)=0.23D0
C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
        MSTP(89)=1
        MSTP(88)=0
C   PARP(79)=2D0
        PARP(80)=0.01D0
C...Peterson charm frag, and c and b hadr parameters
        MSTJ(11)=3
        PARJ(54)=-0.07
        PARJ(55)=-0.006
C...  Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
          WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
          WRITE(M11,5030) CH60
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5050) 84, PARP(84), CHPARP(84)
          WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
          WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
          WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
          WRITE(M11,5050) 79, PARP(79), CHPARP(79)
          WRITE(M11,5050) 80, PARP(80), CHPARP(80)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
          WRITE(M11,5050) 78, PARP(78), CHPARP(78)
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C=======================================================================
C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
      ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
     &      ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
     &      ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
        IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='see R.D. Field, in hep-ph/0610012'
          WRITE(M11,5030) CH60
          CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
            CH60='LEP parameters tuned by Professor'
            WRITE(M11,5030) CH60
          ENDIF
        ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          CH60='LEP/Tevatron parameters tuned by Professor'
          WRITE(M11,5030) CH60
        ENDIF
 
C...Make sure we start from old default fragmentation parameters
        PARJ(81) = 0.29
        PARJ(82) = 1.0
 
C...Use Professor's LEP pars if ITUNE >= 110
C...(i.e., for A-Pro, DW-Pro etc)
        IF (ITUNE.GE.110) THEN
C...# Tuned flavour parameters:
          PARJ(1)  = 0.073
          PARJ(2)  = 0.2
          PARJ(3)  = 0.94
          PARJ(4)  = 0.032
          PARJ(11) = 0.31
          PARJ(12) = 0.4
          PARJ(13) = 0.54
          PARJ(25) = 0.63
          PARJ(26) = 0.12
C...# Switch on Bowler:
          MSTJ(11) = 5
C...# Fragmentation
          PARJ(21) = 0.325
          PARJ(41) = 0.5
          PARJ(42) = 0.6
          PARJ(47) = 0.67
          PARJ(81) = 0.29
          PARJ(82) = 1.65
        ENDIF
 
C...Remove middle digit now for Professor variants, since identical pars
        ITUNEB=ITUNE
        IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
          ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
        ENDIF
 
C...Multiple interactions on, old framework
        MSTP(81)=1
C...Fast IR cutoff energy scaling by default
        PARP(89)=1800D0
        PARP(90)=0.25D0
C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
        MSTP(51)=7
        MSTP(52)=1
        IF (ITUNEB.EQ.105) THEN
          MSTP(51)=10150
          MSTP(52)=2
        ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
          MSTP(52)=2
          MSTP(54)=2
          MSTP(51)=10042
          MSTP(53)=10042
        ENDIF
C...Double Gaussian matter distribution.
        MSTP(82)=4
        PARP(83)=0.5D0
        PARP(84)=0.4D0
C...FSR activity.
        PARP(71)=4D0
C...Fragmentation functions and c and b parameters
C...(only if not using Professor)
        IF (ITUNE.LE.109) THEN
          MSTJ(11)=4
          PARJ(54)=-0.05
          PARJ(55)=-0.005
        ENDIF
 
C...Tune A and AW
        IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
C...pT0.
          PARP(82)=2.0D0
c...String drawing almost completely minimizes string length.
          PARP(85)=0.9D0
          PARP(86)=0.95D0
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1D0
          PARP(64)=1D0
          PARP(67)=4D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=1D0
          PARP(93)=5D0
C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
          IF (ITUNEB.EQ.101) THEN
            PARP(62)=1.25D0
            PARP(64)=0.2D0
            PARP(91)=2.1D0
            PARP(92)=15.0D0
          ENDIF
 
C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
        ELSEIF (ITUNEB.EQ.102) THEN
C...pT0.
          PARP(82)=1.9D0
c...String drawing completely minimizes string length.
          PARP(85)=1.0D0
          PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1.25D0
          PARP(64)=0.2D0
          PARP(67)=1D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=2.1D0
          PARP(93)=15D0
 
C...Tune DW
        ELSEIF (ITUNEB.EQ.103) THEN
C...pT0.
          PARP(82)=1.9D0
c...String drawing completely minimizes string length.
          PARP(85)=1.0D0
          PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1.25D0
          PARP(64)=0.2D0
          PARP(67)=2.5D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=2.1D0
          PARP(93)=15D0
 
C...Tune DWT
        ELSEIF (ITUNEB.EQ.104) THEN
C...pT0.
          PARP(82)=1.9409D0
C...Run II ref scale and slow scaling
          PARP(89)=1960D0
          PARP(90)=0.16D0
c...String drawing completely minimizes string length.
          PARP(85)=1.0D0
          PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1.25D0
          PARP(64)=0.2D0
          PARP(67)=2.5D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=2.1D0
          PARP(93)=15D0
 
C...Tune QW
        ELSEIF(ITUNEB.EQ.105) THEN
          IF (M13.GE.1) THEN
            WRITE(M11,5030) ' '
            CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
     &           'externally linked'
            WRITE(M11,5035) CH70
          ENDIF
C...pT0.
          PARP(82)=1.1D0
c...String drawing completely minimizes string length.
          PARP(85)=1.0D0
          PARP(86)=1.0D0
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1.25D0
          PARP(64)=0.2D0
          PARP(67)=2.5D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=2.1D0
          PARP(93)=15D0
 
C...Tune D6 and D6T
        ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
          IF (M13.GE.1) THEN
            WRITE(M11,5030) ' '
            CH70='NB! This tune requires CTEQ6L pdfs to be '//
     &           'externally linked'
            WRITE(M11,5035) CH70
          ENDIF
C...The "Rick" proton, double gauss with 0.5/0.4
          MSTP(82)=4
          PARP(83)=0.5D0
          PARP(84)=0.4D0
c...String drawing completely minimizes string length.
          PARP(85)=1.0D0
          PARP(86)=1.0D0
          IF (ITUNEB.EQ.108) THEN
C...D6: pT0, Run I ref scale, and fast energy scaling
            PARP(82)=1.8D0
            PARP(89)=1800D0
            PARP(90)=0.25D0
          ELSE
C...D6T: pT0, Run II ref scale, and slow energy scaling
            PARP(82)=1.8387D0
            PARP(89)=1960D0
            PARP(90)=0.16D0
          ENDIF
C...ISR cutoff, muR scale factor, and phase space size
          PARP(62)=1.25D0
          PARP(64)=0.2D0
          PARP(67)=2.5D0
C...Intrinsic kT, size, and max
          MSTP(91)=1
          PARP(91)=2.1D0
          PARP(93)=15D0
 
C...Old ATLAS-DC2 5-parameter tune
        ELSEIF(ITUNEB.EQ.106) THEN
          IF (M13.GE.1) THEN
            WRITE(M11,5010) ITUNE, CHNAME
            CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
            WRITE(M11,5030) CH60
            CH60='    R. Field in hep-ph/0610012,'
            WRITE(M11,5030) CH60
            CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
            WRITE(M11,5030) CH60
          ENDIF
C...  pT0.
          PARP(82)=1.8D0
C...  Different ref and rescaling pacee
          PARP(89)=1000D0
          PARP(90)=0.16D0
C...  Parameters of mass distribution
          PARP(83)=0.5D0
          PARP(84)=0.5D0
C...  Old default string drawing
          PARP(85)=0.33D0
          PARP(86)=0.66D0
C...  ISR, phase space equivalent to Tune B
          PARP(62)=1D0
          PARP(64)=1D0
          PARP(67)=1D0
C...  FSR
          PARP(71)=4D0
C...  Intrinsic kT
          MSTP(91)=1
          PARP(91)=1D0
          PARP(93)=5D0
 
C...Professor's Pro-Q20 Tune
        ELSEIF(ITUNE.EQ.129) THEN
          IF (M13.GE.1) THEN
            CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
            WRITE(M11,5030) CH60
          ENDIF
          PARP(62)=2.9
          PARP(64)=0.14
          PARP(67)=2.65
          PARP(82)=1.9
          PARP(83)=0.83
          PARP(84)=0.6
          PARP(85)=0.86
          PARP(86)=0.93
          PARP(89)=1800D0
          PARP(90)=0.22
          MSTP(91)=1
          PARP(91)=2.1
          PARP(93)=5.0
 
        ENDIF
 
C...  Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5050) 67, PARP(67), CHPARP(67)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5050) 84, PARP(84), CHPARP(84)
          WRITE(M11,5050) 85, PARP(85), CHPARP(85)
          WRITE(M11,5050) 86, PARP(86), CHPARP(86)
          WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
          WRITE(M11,5050) 91, PARP(91), CHPARP(91)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C=======================================================================
C... ACR, tune A with new CR (107)
      ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
        IF (M13.GE.1) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='Tune A modified with new colour reconnections'
          WRITE(M11,5030) CH60
          CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
          WRITE(M11,5030) CH60
          CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
          WRITE(M11,5030) CH60
          CH60='    R. Field, in hep-ph/0610012 (Tune A),'
          WRITE(M11,5030) CH60
          CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          IF (ITUNE.EQ.117) THEN
            CH60='LEP parameters tuned by Professor'
            WRITE(M11,5030) CH60
          ENDIF
        ENDIF
        IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune. Using defaults.')
          GOTO 100
        ENDIF
 
C...Make sure we start from old default fragmentation parameters
        PARJ(81) = 0.29
        PARJ(82) = 1.0
 
C...Use Professor's LEP pars if ITUNE >= 110
C...(i.e., for A-Pro, DW-Pro etc)
        IF (ITUNE.GE.110) THEN
C...# Tuned flavour parameters:
          PARJ(1)  = 0.073
          PARJ(2)  = 0.2
          PARJ(3)  = 0.94
          PARJ(4)  = 0.032
          PARJ(11) = 0.31
          PARJ(12) = 0.4
          PARJ(13) = 0.54
          PARJ(25) = 0.63
          PARJ(26) = 0.12
C...# Switch on Bowler:
          MSTJ(11) = 5
C...# Fragmentation
          PARJ(21) = 0.325
          PARJ(41) = 0.5
          PARJ(42) = 0.6
          PARJ(47) = 0.67
          PARJ(81) = 0.29
          PARJ(82) = 1.65
        ENDIF
 
        MSTP(81)=1
        PARP(89)=1800D0
        PARP(90)=0.25D0
        MSTP(82)=4
        PARP(83)=0.5D0
        PARP(84)=0.4D0
        MSTP(51)=7
        MSTP(52)=1
        PARP(71)=4D0
        PARP(82)=2.0D0
        PARP(85)=0.0D0
        PARP(86)=0.66D0
        PARP(62)=1D0
        PARP(64)=1D0
        PARP(67)=4D0
        MSTP(91)=1
        PARP(91)=1D0
        PARP(93)=5D0
        MSTP(95)=6
C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
        PARP(78)=0.09D0
C...Frag functions (only if not using Professor)
        IF (ITUNE.LE.109) THEN
          MSTJ(11)=4
          PARJ(54)=-0.05
          PARJ(55)=-0.005
        ENDIF
 
C...Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5050) 67, PARP(67), CHPARP(67)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5050) 84, PARP(84), CHPARP(84)
          WRITE(M11,5050) 85, PARP(85), CHPARP(85)
          WRITE(M11,5050) 86, PARP(86), CHPARP(86)
          WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
          WRITE(M11,5050) 91, PARP(91), CHPARP(91)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
          WRITE(M11,5050) 78, PARP(78), CHPARP(78)
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C=======================================================================
C...Intermediate model. Rap tune
C...(retuned to post-6.406 IR factorization)
      ELSEIF(ITUNE.EQ.200) THEN
        IF (M13.GE.1) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
          WRITE(M11,5030) CH60
        ENDIF
        IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune.')
        ENDIF
C...PDF
        MSTP(51)=7
        MSTP(52)=1
C...ISR
        PARP(62)=1D0
        PARP(64)=1D0
        PARP(67)=4D0
C...FSR
        PARP(71)=4D0
        PARJ(81)=0.29D0
C...UE
        MSTP(81)=11
        PARP(82)=2.25D0
        PARP(89)=1800D0
        PARP(90)=0.25D0
C...  ExpOfPow(1.8) overlap profile
        MSTP(82)=5
        PARP(83)=1.8D0
C...  Valence qq
        MSTP(88)=0
C...  Rap Tune
        MSTP(89)=1
C...  Default diquark, BR-g-BR supp
        PARP(79)=2D0
        PARP(80)=0.01D0
C...  Final state reconnect.
        MSTP(95)=1
        PARP(78)=0.55D0
C...Fragmentation functions and c and b parameters
        MSTJ(11)=4
        PARJ(54)=-0.05
        PARJ(55)=-0.005
C...  Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5050) 67, PARP(67), CHPARP(67)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
          WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
          WRITE(M11,5050) 79, PARP(79), CHPARP(79)
          WRITE(M11,5050) 80, PARP(80), CHPARP(80)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
          WRITE(M11,5050) 78, PARP(78), CHPARP(78)
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
C...Old model for ISR and UE, new pT-ordered model for FSR
      ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
     &       .ITUNE.EQ.226) THEN
        IF (M13.GE.1) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
          WRITE(M11,5030) CH60
          CH60='    R.D. Field, in hep-ph/0610012 (Tune A)'
          WRITE(M11,5030) CH60
          CH60='    T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
          WRITE(M11,5030) CH60
          IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
            CH60='LEP parameters tuned by Professor'
            WRITE(M11,5030) CH60
          ENDIF
        ENDIF
        IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
          CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
     &        ' with tune.')
        ENDIF
C...First set as if Pythia tune A
C...Multiple interactions on, old framework
        MSTP(81)=1
C...Fast IR cutoff energy scaling by default
        PARP(89)=1800D0
        PARP(90)=0.25D0
C...Default CTEQ5L (internal)
        MSTP(51)=7
        MSTP(52)=1
C...Double Gaussian matter distribution.
        MSTP(82)=4
        PARP(83)=0.5D0
        PARP(84)=0.4D0
C...FSR activity.
        PARP(71)=4D0
c...String drawing almost completely minimizes string length.
        PARP(85)=0.9D0
        PARP(86)=0.95D0
C...ISR cutoff, muR scale factor, and phase space size
        PARP(62)=1D0
        PARP(64)=1D0
        PARP(67)=4D0
C...Intrinsic kT, size, and max
        MSTP(91)=1
        PARP(91)=1D0
        PARP(93)=5D0
C...Use 2 GeV of primordial kT for "Perugia" version
        IF (ITUNE.EQ.221) THEN
          PARP(91)=2D0
          PARP(93)=10D0
        ENDIF
C...Use pT-ordered FSR
        MSTJ(41)=12
C...Lambda_FSR scale for pT-ordering
        PARJ(81)=0.23D0
C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
        PARP(82)=2.05D0
C...Fragmentation functions and c and b parameters
C...(overwritten for 211, i.e., if using Professor pars)
        MSTJ(11)=4
        PARJ(54)=-0.05
        PARJ(55)=-0.005
 
C...Use Professor's LEP pars if ITUNE == 211, 221, 226
        IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
C...# Tuned flavour parameters:
          PARJ(1)  = 0.073
          PARJ(2)  = 0.2
          PARJ(3)  = 0.94
          PARJ(4)  = 0.032
          PARJ(11) = 0.31
          PARJ(12) = 0.4
          PARJ(13) = 0.54
          PARJ(25) = 0.63
          PARJ(26) = 0.12
C...# Always use pT-ordered shower:
          MSTJ(41) = 12
C...# Switch on Bowler:
          MSTJ(11) = 5
C...# Fragmentation
          PARJ(21) = 3.1327e-01
          PARJ(41) = 4.8989e-01
          PARJ(42) = 1.2018e+00
          PARJ(47) = 1.0000e+00
          PARJ(81) = 2.5696e-01
          PARJ(82) = 8.0000e-01
        ENDIF
 
C...221, 226 : Perugia-APT and Perugia-APT6
        IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
 
          PARP(64)=0.5D0
          PARP(82)=2.05D0
          PARP(90)=0.26D0
          PARP(91)=2.0D0
C...The Perugia variants use Steve's showers off the old MPI
          MSTP(152)=1
C...And use a lower PARP(71) as suggested by Professor tunings
C...(although not certain that applies to Q2-pT2 hybrid)
          PARP(71)=2.5D0
 
C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
          IF (ITUNE.EQ.226) THEN
            CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
     &           'externally linked'
            WRITE(M11,5035) CH70
            MSTP(52)=2
            MSTP(51)=10042
            PARP(82)=1.95D0
          ENDIF
 
        ENDIF
 
C...  Output
        IF (M13.GE.1) THEN
          WRITE(M11,5030) ' '
          WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
          WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
          WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          WRITE(M11,5050) 64, PARP(64), CHPARP(64)
          WRITE(M11,5050) 67, PARP(67), CHPARP(67)
          WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
          CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
          WRITE(M11,5030) CH60
          WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
          WRITE(M11,5050) 71, PARP(71), CHPARP(71)
          WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
          WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
          WRITE(M11,5050) 82, PARP(82), CHPARP(82)
          WRITE(M11,5050) 89, PARP(89), CHPARP(89)
          WRITE(M11,5050) 90, PARP(90), CHPARP(90)
          WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          WRITE(M11,5050) 83, PARP(83), CHPARP(83)
          WRITE(M11,5050) 84, PARP(84), CHPARP(84)
          WRITE(M11,5050) 85, PARP(85), CHPARP(85)
          WRITE(M11,5050) 86, PARP(86), CHPARP(86)
          WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
          WRITE(M11,5050) 91, PARP(91), CHPARP(91)
          WRITE(M11,5050) 93, PARP(93), CHPARP(93)
          WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
          WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
          WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          IF (MSTJ(11).LE.3) THEN
             WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
             WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
          ELSE
             WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
          ENDIF
          IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
        ENDIF
 
C======================================================================
C...Uppsala models: Generalized Area Law and Soft Colour Interactions
      ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
        IF (M13.GE.1) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='see J. Rathsman, PLB452(1999)364'
          WRITE(M11,5030) CH60
C ?         CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
C ?         WRITE(M11,5030)
          CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          WRITE(M11,5030) ' '
          CH70='NB! The GAL model must be run with modified '//
     &        'Pythia v6.215:'
          WRITE(M11,5035) CH70
          CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
          WRITE(M11,5035) CH70
          WRITE(M11,5030) ' '
        ENDIF
C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
        MSWI(2) = 3
        PARSCI(2) = 0.10
        MSWI(1) = 2
        PARSCI(1) = 0.44
        MSTJ(16) = 0
        PARJ(42) = 0.45
        PARJ(82) = 2.0
        PARP(62) = 2.0  
        MSTP(81) = 1
        MSTP(82) = 1
        PARP(81) = 1.9
        MSTP(92) = 1
        IF(CHNAME.EQ.'GAL Tune 1') THEN
C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
          MSTP(82)=4
          PARP(83)=0.25D0
          PARP(84)=0.5D0
          PARP(82) = 1.75
          IF (M13.GE.1) THEN
            WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
            WRITE(M11,5050) 82, PARP(82), CHPARP(82)
            WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
            WRITE(M11,5050) 83, PARP(83), CHPARP(83)
            WRITE(M11,5050) 84, PARP(84), CHPARP(84)
          ENDIF
        ELSE
          IF (M13.GE.1) THEN
            WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
            WRITE(M11,5050) 81, PARP(81), CHPARP(81)
            WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          ENDIF
        ENDIF
C...Output
        IF (M13.GE.1) THEN
          WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
          WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
          CH40='FSI SCI/GAL selection'
          WRITE(M11,6040) 1, MSWI(1), CH40
          CH40='FSI SCI/GAL sea quark treatment'
          WRITE(M11,6040) 2, MSWI(2), CH40
          CH40='FSI SCI/GAL sea quark treatment parm'
          WRITE(M11,6050) 1, PARSCI(1), CH40
          CH40='FSI SCI/GAL string reco probability R_0'
          WRITE(M11,6050) 2, PARSCI(2), CH40
          WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
          WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
        ENDIF
      ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
        IF (M13.GE.1) THEN
          WRITE(M11,5010) ITUNE, CHNAME
          CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
          WRITE(M11,5030) CH60
          CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
          WRITE(M11,5030) CH60
          WRITE(M11,5030) ' '
          CH70='NB! The SCI model must be run with modified '//
     &        'Pythia v6.215:'
          WRITE(M11,5035) CH70
          CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
          WRITE(M11,5035) CH70
          WRITE(M11,5030) ' '
        ENDIF
C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
        MSTP(81)=1
        MSTP(82)=1
        PARP(81)=2.2
        MSTP(92)=1
        MSWI(2)=2
        PARSCI(2)=0.50
        MSWI(1)=2
        PARSCI(1)=0.44
        MSTJ(16)=0
        IF (CHNAME.EQ.'SCI Tune 1') THEN
C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
          MSTP(81) = 1
          MSTP(82) = 3
          PARP(82) = 2.4
          PARP(83) = 0.5D0
          PARP(62) = 1.5
          PARP(84)=0.25D0
          IF (M13.GE.1) THEN
            WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
            WRITE(M11,5050) 82, PARP(82), CHPARP(82)
            WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
            WRITE(M11,5050) 83, PARP(83), CHPARP(83)
            WRITE(M11,5050) 62, PARP(62), CHPARP(62)
          ENDIF
        ELSE
          IF (M13.GE.1) THEN
            WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
            WRITE(M11,5050) 81, PARP(81), CHPARP(81)
            WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
          ENDIF
        ENDIF
C...Output
        IF (M13.GE.1) THEN
          WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
          CH40='FSI SCI/GAL selection'
          WRITE(M11,6040) 1, MSWI(1), CH40
          CH40='FSI SCI/GAL sea quark treatment'
          WRITE(M11,6040) 2, MSWI(2), CH40
          CH40='FSI SCI/GAL sea quark treatment parm'
          WRITE(M11,6050) 1, PARSCI(1), CH40
          CH40='FSI SCI/GAL string reco probability R_0'
          WRITE(M11,6050) 2, PARSCI(2), CH40
          WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
        ENDIF
 
      ELSE
        IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
 
      ENDIF
 
  100 IF (MSTU(13).GE.1) WRITE(M11,6000)
 
 9999 RETURN
 
 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
     &    'Presets for underlying-event (and min-bias)',13x,'*'/' *',
     &    20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
 5030 FORMAT(' *',3x,10x,A60,3x,'*')
 5035 FORMAT(' *',3x,A70,3x,'*')
 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
 6040 FORMAT(' *',5x,'MSWI(',I1,')  = ',I12,3x,A40,5x,'*')
 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
 
      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(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT4/MWID(500),WIDS(500,5)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
C...Local array.
      DIMENSION PS(2,6),IJOIN(100)
 
C...Initialize and reset.
      MSTU(24)=0
      IF(MSTU(12).NE.12345) CALL PYLIST(0)
      MSTU(29)=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...Start by all decays of coloured resonances involved in shower.
      NORIG=N
      DO 140 I=1,NORIG
        IF(K(I,1).EQ.3) THEN
          KC=PYCOMP(K(I,2))
          IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
        ENDIF
  140 CONTINUE
 
C...Prepare system for subsequent fragmentation/decay.
      CALL PYPREP(0)
      IF(MINT(51).NE.0) RETURN
 
C...Loop through jet fragmentation and particle decays.
      MBE=0
  150 MBE=MBE+1
      IP=0
  160 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
  170     IBEG=IBEG-1
          IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
          IF(K(IBEG,1).NE.2) IBEG=IBEG+1
          IEND=IP-1
  180     IEND=IEND+1
          IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
          IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
          NJOIN=0
          DO 190 I=IBEG,IEND
            IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
              NJOIN=NJOIN+1
              IJOIN(NJOIN)=I
            ENDIF
  190     CONTINUE
        ENDIF
        CALL PYRESD(IP)
        CALL PYPREP(IBEG)
        IF(MINT(51).NE.0) RETURN
 
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))
          MINT(33)=0
          CALL PYSHOW(IP1,IP1+1,QMAX)
          CALL PYPREP(IP1)
          IF(MINT(51).NE.0) RETURN
          MSTJ(92)=0
        ELSEIF(MSTJ(92).LT.0) THEN
          IP1=-MSTJ(92)
          MINT(33)=0
          CALL PYSHOW(IP1,-3,P(IP,5))
          CALL PYPREP(IP1)
          IF(MINT(51).NE.0) RETURN
          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 160
      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 150
      ENDIF
 
C...Check that momentum, energy and charge were conserved.
      DO 210 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
        DO 200 J=1,4
          PS(2,J)=PS(2,J)+P(I,J)
  200   CONTINUE
        PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
  210 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...Special considerations for systems with junctions, with
C...possibility of junction-antijunction annihilation.
C...Allows small systems to collapse into one or two particles.
C...Checks flavours and colour singlet invariant 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/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYINT1/MINT(400),VINT(400)
C...The common block of colour tags.
      COMMON/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
     &/PYPARS/
      DATA NERRPR/0/
      SAVE NERRPR
C...Local arrays.
      DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
     &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
     &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
     &IJCP(0:6),TJUOLD(5)
      CHARACTER CHTMP*6
 
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.
      MSTU(24)=0
      NOLD=N
      I1=N
      NJUNC=0
      NPIECE=0
      NJJSTR=0
      MSTU32=MSTU(32)+1
      DO 100 I=MAX(1,IP),N
C...First store junction positions.
        IF(K(I,1).EQ.42) THEN
          NJUNC=NJUNC+1
          IJUNC(NJUNC,0)=I
          IJUNC(NJUNC,4)=0
        ENDIF
  100 CONTINUE
 
      DO 250 MQGST=1,3
        DO 240 I=MAX(1,IP),N
C...Special treatment for junctions
          IF (K(I,1).LE.0) GOTO 240
          IF(K(I,1).EQ.42) THEN
C...MQGST=2: Look for junction-junction strings (not detected in the
C...main search below).
            IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
              IF (NJJSTR.EQ.0) THEN
                NJJSTR = (3*NJUNC-NPIECE)/2
              ENDIF
C...Check how many already identified strings end on this junction
              ILC=0
              DO 110 J=1,NPIECE
                IF (IPIECE(J,4).EQ.I) ILC=ILC+1
  110         CONTINUE
C...If less than 3, remaining must be to another junction
              IF (ILC.LT.3) THEN
                IF (ILC.NE.2) THEN
C...Multiple j-j connections not handled yet.
                  CALL PYERRM(2,
     &            '(PYPREP:) Too many junction-junction strings.')
                  MINT(51)=1
                  RETURN
                ENDIF
C...The colour information in the junction is unreadable for the
C...colour space search further down in this routine, so we must
C...start on the colour mother of this junction and then "artificially"
C...prevent the colour mother from connecting here again.
                ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
                KCS=4
                IF (MOD(ITJUNC,2).EQ.0) KCS=5
C...Switch colour if the junction-junction leg is presumably a
C...junction mother leg rather than a junction daughter leg.
                IF (ITJUNC.GE.3) KCS=9-KCS
                IF (MINT(33).EQ.0) THEN
C...Find the unconnected leg and reorder junction daughter pointers so
C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
C...piece.
                  IA=MOD(K(I,4),MSTU(5))
                  IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
                    ITMP=MOD(K(I,5),MSTU(5))
                    IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
                      ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
                      K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
                    ELSE
                      K(I,5)=K(I,5)+(IA-ITMP)
                    ENDIF
                    K(I,4)=K(I,4)+(ITMP-IA)
                    IA=ITMP
                  ENDIF
                  IF (ITJUNC.LE.2) THEN
C...Beam baryon junction
                    K(IA,KCS)   = K(IA,KCS) + 2*MSTU(5)**2
                    K(I,KCS)    = K(I,KCS) + 1*MSTU(5)**2
C...Else 1 -> 2 decay junction
                  ELSE
                    K(IA,KCS)   = K(IA,KCS) + MSTU(5)**2
                    K(I,KCS)    = K(I,KCS) + 2*MSTU(5)**2
                  ENDIF
                  I1BEG = I1
                  NSTP = 0
                  GOTO 170
C...Alternatively use colour tag information.
                ELSE
C...Find a final state parton with appropriate dangling colour tag.
                  JCT=0
                  IA=0
                  IJUMO=K(I,3)
                  DO 140 J1=MAX(1,IP),N
                    IF (K(J1,1).NE.3) GOTO 140
C...Check for matching final-state colour tag
                    IMATCH=0
                    DO 120 J2=MAX(1,IP),N
                      IF (K(J2,1).NE.3) GOTO 120
                      IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
  120               CONTINUE
                    IF (IMATCH.EQ.1) GOTO 140
C...Check whether this colour tag belongs to the present junction
C...by seeing whether any parton with this colour tag has the same
C...mother as the junction.
                    JCT=MCT(J1,KCS-3)
                    IMATCH=0
                    DO 130 J2=MINT(84)+1,N
                      IMO2=K(J2,3)
C...First scattering partons have IMO1 = 3 and 4.
                      IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
     &                     IMO2=IMO2-2
                      IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
     &                     IMATCH=1
  130               CONTINUE
                    IF (IMATCH.EQ.0) GOTO 140
                    IA=J1
  140             CONTINUE
C...Check for junction-junction strings without intermediate final state
C...glue (not detected above).
                  IF (IA.EQ.0) THEN
                    DO 160 MJU=1,NJUNC
                      IJU2=IJUNC(MJU,0)
                      IF (IJU2.EQ.I) GOTO 160
                      ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
C...Only opposite types of junctions can connect to each other.
                      IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
                      IS=0
                      DO 150 J=1,NPIECE
                        IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
  150                 CONTINUE
                      IF (IS.EQ.3) GOTO 160
                      IB=I
                      IA=IJU2
  160               CONTINUE
                  ENDIF
C...Switch to other side of adjacent parton and step from there.
                  KCS=9-KCS
                  I1BEG = I1
                  NSTP = 0
                  GOTO 170
                ENDIF
              ELSE IF (ILC.NE.3) THEN
              ENDIF
            ENDIF
          ENDIF
 
C...Look for coloured string endpoint, or (later) leftover gluon.
          IF(K(I,1).NE.3) GOTO 240
          KC=PYCOMP(K(I,2))
          IF(KC.EQ.0) GOTO 240
          KQ=KCHG(KC,2)
          IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
 
C...Pick up loose string end.
          KCS=4
          IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
          IA=I
          IB=I
          I1BEG=I1
          NSTP=0
  170     NSTP=NSTP+1
          IF(NSTP.GT.4*N) THEN
            CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
            MINT(51)=1
            RETURN
          ENDIF
 
C...Copy undecayed parton. Finished if reached string endpoint.
          IF(K(IA,1).EQ.3) THEN
            IF(I1.GE.MSTU(4)-MSTU32-5) THEN
              CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
              MINT(51)=1
              MSTU(24)=1
              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 180 J=1,5
              P(I1,J)=P(IA,J)
              V(I1,J)=V(IA,J)
  180       CONTINUE
            K(IA,1)=K(IA,1)+10
            IF(K(I1,1).EQ.1) GOTO 240
          ENDIF
 
C...Also finished (for now) if reached junction; then copy to end.
          IF(K(IA,1).EQ.42) THEN
            NCOPY=I1-I1BEG
            IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
              CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
              MINT(51)=1
              MSTU(24)=1
              RETURN
            ENDIF
            IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
              DO 200 ICOPY=1,NCOPY
                DO 190 J=1,5
                  K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
                  P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
                  V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
  190           CONTINUE
  200         CONTINUE
            ENDIF
C...For junction-junction strings, find end leg and reorder junction
C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
C...junction-junction string piece.
            IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
              ITMP=MOD(K(IA,4),MSTU(5))
              IF (ITMP.NE.IB) THEN
                IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
                  K(IA,5)=K(IA,5)+(ITMP-IB)
                ELSE
                  K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
                ENDIF
                K(IA,4)=K(IA,4)+(IB-ITMP)
              ENDIF
            ENDIF
            NPIECE=NPIECE+1
C...IPIECE:
C...0: endpoint in original ER
C...1:
C...2:
C...3: Parton immediately next to junction
C...4: Junction
            IPIECE(NPIECE,0)=I
            IPIECE(NPIECE,1)=MSTU32+1
            IPIECE(NPIECE,2)=MSTU32+NCOPY
            IPIECE(NPIECE,3)=IB
            IPIECE(NPIECE,4)=IA
            MSTU32=MSTU32+NCOPY
            I1=I1BEG
            GOTO 240
          ENDIF
 
C...GOTO next parton in colour space.
          IB=IA
          IF (MINT(33).EQ.0) THEN
            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')
              IF(NERRPR.LT.5) THEN
                NERRPR=NERRPR+1
                WRITE(MSTU(11),*) 'started at:', I
                WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
                WRITE(MSTU(11),*) 'MQGST =',MQGST
                CALL PYLIST(4)
              ENDIF
              MINT(51)=1
              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 170
C...Use colour tag information
          ELSE
C...First create colour tags starting on IB if none already present.
            IF (MCT(IB,KCS-3).EQ.0) THEN
              CALL PYCTTR(IB,KCS,IB)
              IF(MINT(51).NE.0) RETURN
            ENDIF
            JCT=MCT(IB,KCS-3)
            IFOUND=0
C...Find final state tag partner
            DO 210 IT=MAX(1,IP),N
              IF (IT.EQ.IB) GOTO 210
              IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
     &             .0) THEN
                IFOUND=IFOUND+1
                IA=IT
              ENDIF
  210       CONTINUE
C...Just copy and goto next if exactly one partner found.
            IF (IFOUND.EQ.1) THEN
              GOTO 170
C...When no match found, match is presumably junction.
            ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
C...Check whether this colour tag matches a junction
C...by seeing whether any parton with this colour tag has the same
C...mother as a junction.
C...NB: Only type 1 and 2 junctions handled presently.
              DO 230 IJU=1,NJUNC
                IJUMO=K(IJUNC(IJU,0),3)
                ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
C...Colours only connect to junctions, anti-colours to antijunctions:
                IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
                IMATCH=0
                DO 220 J1=MAX(1,IP),N
                  IF (K(J1,1).LE.0) GOTO 220
C...First scattering partons have IMO1 = 3 and 4.
                  IMO=K(J1,3)
                  IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
     &                 IMO=IMO-2
                  IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
     &                 ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
     &                 IMATCH=1
C...Attempt at handling type > 3 junctions also. Not tested.
                  IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
     &                 .IJUMO) IMATCH=1
  220           CONTINUE
                IF (IMATCH.EQ.0) GOTO 230
                IA=IJUNC(IJU,0)
                IFOUND=IFOUND+1
  230         CONTINUE
 
              IF (IFOUND.EQ.1) THEN
                GOTO 170
              ELSEIF (IFOUND.EQ.0) THEN
                WRITE(CHTMP,*) JCT
                CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
     &               //CHTMP)
                IF(NERRPR.LT.5) THEN
                  NERRPR=NERRPR+1
                  CALL PYLIST(4)
                ENDIF
                MINT(51)=1
                RETURN
              ENDIF
            ELSEIF (IFOUND.GE.2) THEN
              WRITE(CHTMP,*) JCT
              CALL PYERRM(12
     &             ,'(PYPREP:) too many occurences of colour line: '//
     &             CHTMP)
              IF(NERRPR.LT.5) THEN
                NERRPR=NERRPR+1
                CALL PYLIST(4)
              ENDIF
              MINT(51)=1
              RETURN
            ENDIF
          ENDIF
          K(I1,1)=1
  240   CONTINUE
  250 CONTINUE
 
C...Junction systems remain.
      IJU=0
      IJUS=0
      IJUCNT=0
      MREV=0
      IJJSTR=0
  260 IJUCNT=IJUCNT+1
      IF (IJUCNT.LE.NJUNC) THEN
C...If we are not processing a j-j string, treat this junction as new.
        IF (IJJSTR.EQ.0) THEN
          IJU=IJUNC(IJUCNT,0)
          MREV=0
C...If junction has already been read, ignore it.
          IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
C...If we are on a j-j string, goto second j-j junction.
        ELSE
          IJUCNT=IJUCNT-1
          IJU=IJUS
        ENDIF
C...Mark selected junction read.
        DO 270 J=1,NJUNC
          IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
  270   CONTINUE
C...Determine junction type
        ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
        IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
          IHK=0
  280     IHK=IHK+1
C...Find which quarks belong to given junction.
          IHF=0
          DO 290 IPC=1,NPIECE
            IF (IPIECE(IPC,4).EQ.IJU) THEN
              IHF=IHF+1
              IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
            ENDIF
            IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
  290     CONTINUE
C...IHK = 3 is special. Either normal string piece, or j-j string.
          IF(IHK.EQ.3) THEN
            IF (MREV.NE.1) THEN
              DO 300 IPC=1,NPIECE
C...If there is a j-j string starting on the present junction which has
C...zero length, insert next junction immediately.
                IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
     &          .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
                  IJJSTR = 1
                  GOTO 340
                ENDIF
  300         CONTINUE
              MREV = 1
C...If MREV is 1 and IHK is 3 we are finished with this system.
            ELSE
              MREV=0
              GOTO 260
            ENDIF
          ENDIF
 
C...If we've gotten this far, then either IHK < 3, or
C...an interjunction string exists, or just a third normal string.
          IJUNC(IJUCNT,IHK)=0
          IJJSTR = 0
C..Order pieces belonging to this junction. Also look for j-j.
          DO 310 IPC=1,NPIECE
            IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
            IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
     &      .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
              IJUNC(IJUCNT,IHK)=IPC
              IJJSTR = 1
              MREV = 0
            ENDIF
  310     CONTINUE
C...Copy back chains in proper order. MREV=0/1 : descending/ascending
          IPC=IJUNC(IJUCNT,IHK)
C...Temporary solution to cover for bug.
          IF(IPC.LE.0) THEN
            CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
            MINT(51)=1
            RETURN
          ENDIF
          DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
            I1=I1+1
            DO 320 J=1,5
              K(I1,J)=K(MSTU(4)-ICP,J)
              P(I1,J)=P(MSTU(4)-ICP,J)
              V(I1,J)=V(MSTU(4)-ICP,J)
  320       CONTINUE
  330     CONTINUE
          K(I1,1)=2
C...Mark last quark.
          IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
C...Do not insert junctions at wrong places.
          IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
C...Insert junction.
  340     IJUS = IJU
          IF (IHK.EQ.3) THEN
C...Shift to end junction if a j-j string has been processed.
            IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
            MREV= 1
          ENDIF
          I1=I1+1
          DO 350 J=1,5
            K(I1,J)=0
            P(I1,J)=0.
            V(I1,J)=0.
  350     CONTINUE
          K(I1,1)=41
          K(IJUS,1)=K(IJUS,1)+10
          K(I1,2)=K(IJUS,2)
          K(I1,3)=IJUS
  360     IF (IHK.LT.3) GOTO 280
        ELSE
          CALL PYERRM(12,'(PYPREP:) Unknown junction type')
          MINT(51)=1
          RETURN
        ENDIF
        IF (IJUCNT.NE.NJUNC) GOTO 260
      ENDIF
      N=I1
 
C...Rearrange three strings from junction, e.g. in case one has been
C...shortened by shower, so the last is the largest-energy one.
      IF(NJUNC.GE.1) THEN
C...Find systems with exactly one junction.
        MJUN1=0
        NBEG=NOLD+1
        DO 470 I=NOLD+1,N
          IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
          ELSEIF(K(I,1).EQ.41) THEN
            MJUN1=MJUN1+1
          ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
            MJUN1=0
            NBEG=I+1
          ELSE
            NEND=I
C...Sum up energy-momentum in each junction string.
            DO 370 J=1,5
              PJU(1,J)=0D0
              PJU(2,J)=0D0
              PJU(3,J)=0D0
  370       CONTINUE
            NJU=0
            DO 390 I1=NBEG,NEND
              IF(K(I1,2).NE.21) THEN
                NJU=NJU+1
                IJUR(NJU)=I1
              ENDIF
              DO 380 J=1,5
                PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
  380         CONTINUE
  390       CONTINUE
C...Find which of them has highest energy (minus mass) in rest frame.
            DO 400 J=1,5
              PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
  400       CONTINUE
            PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
     &      PJU(4,3)**2))
            DO 410 I2=1,3
              PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
     &        PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
  410       CONTINUE
            IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
C...Decide how to rearrange so that new last has highest energy.
              IF(PJU(1,6).LT.PJU(2,6)) THEN
                IRNG(1,1)=IJUR(1)
                IRNG(1,2)=IJUR(2)-1
                IRNG(2,1)=IJUR(4)
                IRNG(2,2)=IJUR(3)+1
                IRNG(4,1)=IJUR(3)-1
                IRNG(4,2)=IJUR(2)
              ELSE
                IRNG(1,1)=IJUR(4)
                IRNG(1,2)=IJUR(3)+1
                IRNG(2,1)=IJUR(2)
                IRNG(2,2)=IJUR(3)-1
                IRNG(4,1)=IJUR(2)-1
                IRNG(4,2)=IJUR(1)
              ENDIF
              IRNG(3,1)=IJUR(3)
              IRNG(3,2)=IJUR(3)
C...Copy in correct order below bottom of current event record.
              I2=N
              DO 440 II=1,4
                DO 430 I1=IRNG(II,1),IRNG(II,2),
     &          ISIGN(1,IRNG(II,2)-IRNG(II,1))
                  I2=I2+1
                  IF(I2.GE.MSTU(4)-MSTU32-5) THEN
                    CALL PYERRM(11,
     &              '(PYPREP:) no more memory left in PYJETS')
                    MINT(51)=1
                    MSTU(24)=1
                    RETURN
                  ENDIF
                  DO 420 J=1,5
                    K(I2,J)=K(I1,J)
                    P(I2,J)=P(I1,J)
                    V(I2,J)=V(I1,J)
  420             CONTINUE
                  IF(K(I2,1).EQ.1) K(I2,1)=2
  430           CONTINUE
  440         CONTINUE
              K(I2,1)=1
C...Copy back up, overwriting but now in correct order.
              DO 460 I1=NBEG,NEND
                I2=I1-NBEG+N+1
                DO 450 J=1,5
                  K(I1,J)=K(I2,J)
                  P(I1,J)=P(I2,J)
                  V(I1,J)=V(I2,J)
  450           CONTINUE
  460         CONTINUE
            ENDIF
            MJUN1=0
            NBEG=I+1
          ENDIF
  470   CONTINUE
 
C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
C...to two q-qbar systems.
C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
        IF (MSTJ(19).NE.1) THEN
          MJUN1  = 0
          JJGLUE = 0
          NBEG   = NOLD+1
C...Force collapse when MSTJ(19)=2.
          IF (MSTJ(19).EQ.2) THEN
            DELMJJ = 1D9
            DELMQQ = 0D0
          ENDIF
C...Find systems with exactly two junctions.
          DO 700 I=NOLD+1,N
C...Count junctions
            IF (K(I,1).EQ.41) THEN
              MJUN1 = MJUN1+1
C...Check for interjunction gluons
              IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
                JJGLUE = 1
              ENDIF
            ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
C...If end of system reached with either zero or one junction, restart
C...with next system.
              MJUN1  = 0
              JJGLUE = 0
              NBEG   = I+1
            ELSEIF(K(I,1).EQ.1) THEN
C...If end of system reached with exactly two junctions, compute string
C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
C...length measure for the (q-qbar)(q-qbar) topology.
              NEND=I
C...Loop down through chain.
              ISID=0
              DO 480 I1=NBEG,NEND
C...Store string piece division locations in event record
                IF (K(I1,2).NE.21) THEN
                  ISID       = ISID+1
                  IJCP(ISID) = I1
                ENDIF
  480         CONTINUE
C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
              ISW=0
              IF (PYR(0).LT.0.5D0) ISW=1
C...Randomly choose which qqbar string gets the jj gluons.
              IGS=1
              IF (PYR(0).GT.0.5D0) IGS=2
C...Only compute string lengths when no topology forced.
              IF (MSTJ(19).EQ.0) THEN
C...Repeat following for each junction
                DO 570 IJU=1,2
C...Initialize iterative procedure for finding JRF
                  IJRFIT=0
                  DO 490 IX=1,3
                    TJUOLD(IX)=0D0
  490             CONTINUE
                  TJUOLD(4)=1D0
C...Start iteration. Sum up momenta in string pieces
  500             DO 540 IJS=1,3
C...JD=-1 for first junction, +1 for second junction.
C...Find out where piece starts and ends and which direction to go.
                    JD=2*IJU-3
                    IF (IJS.LE.2) THEN
                      IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
                      IB = IJCP((IJU-1)*7 - JD*IJS)
                    ELSEIF (IJS.EQ.3) THEN
                      JD =-JD
                      IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
                      IB = IJCP((IJU-1)*7 + JD*(IJS+3))
                    ENDIF
C...Initialize junction pull 4-vector.
                    DO 510 J=1,5
                      PUL(IJS,J)=0D0
  510               CONTINUE
C...Initialize weight
                    PWT = 0D0
                    PWTOLD = 0D0
C...Sum up (weighted) momenta along each string piece
                    DO 530 ISP=IA,IB,JD
C...If present parton not last in chain
                      IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
C...If last parton was a junction, store present weight
                        IF (K(ISP-JD,2).EQ.88) THEN
                          PWTOLD = PWT
C...If last parton was a quark, reset to stored weight.
                        ELSEIF (K(ISP-JD,2).NE.21) THEN
                          PWT = PWTOLD
                        ENDIF
                      ENDIF
C...Skip next parton if weight already large
                      IF (PWT.GT.10D0) GOTO 530
C...Compute momentum in TJUOLD frame:
                      TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
     &                     )*P(ISP,3)
                      BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
                      DO 520 J=1,3
                        TMP=P(ISP,J)+TJUOLD(J)*BFC
                        PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
  520                 CONTINUE
C...Boosted energy
                      TMP=TJUOLD(4)*P(ISP,4)+TDP
                      PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
C...Update weight
                      PWT=PWT+TMP/PARJ(48)
C...Put |p| rather than m in 5th slot
                      PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
     &                     +PUL(IJS,3)**2)
  530               CONTINUE
  540             CONTINUE
C...Compute boost
                  IJRFIT=IJRFIT+1
                  CALL PYJURF(PUL,T)
C...Combine new boost (T) with old boost (TJUOLD)
                  TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
                  DO 550 IX=1,3
                    TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
     &                   ))
  550             CONTINUE
                  TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
     &                 **2)
C...If last boost small, accept JRF, else iterate.
C...Also prevent possibility of infinite loop.
                  IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
     &                 IJRFIT.LT.MSTJ(18))THEN
                    GOTO 500
                  ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
                    CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
                  ENDIF
C...Store final boost, with change of sign since TJJ motion vector.
                  DO 560 IX=1,3
                    TJJ(IJU,IX)=-TJUOLD(IX)
  560             CONTINUE
                  TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
     &                 +TJJ(IJU,3)**2)
  570           CONTINUE
C...String length measure for (q-qbar)(q-qbar) topology.
C...Note only momenta of nearest partons used (since rest of system
C...identical).
                IF (JJGLUE.EQ.0) THEN
                  DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
     &                 -1,IJCP(5-ISW)+1)
                ELSE
C...Put jj gluons on selected string (IGS selected randomly above).
                  IF (IGS.EQ.1) THEN
                    DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
     &                   ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
                  ELSE
                    DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
     &                   *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
     &                   ,IJCP(5-ISW)+1)
                  ENDIF
                ENDIF
C...String length measure for q-q-j-j-q-q topology.
                T1G1=0D0
                T2G2=0D0
                T1T2=0D0
                T1P1=0D0
                T1P2=0D0
                T2P3=0D0
                T2P4=0D0
                ISGN=-1
C...Note only momenta of nearest partons used (since rest of system
C...identical).
                DO 580 IX=1,4
                  IF (IX.EQ.4) ISGN=1
                  T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
                  T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
                  T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
                  T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
                  IF (JJGLUE.EQ.0) THEN
C...Junction motion vector dot product gives length when inter-junction
C...gluons absent.
                    T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
                  ELSE
C...Junction motion vector dot products with gluon momenta give length
C...when inter-junction gluons present.
                    T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
                    T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
                  ENDIF
  580           CONTINUE
                DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
                IF (JJGLUE.EQ.0) THEN
                  DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
                ELSE
                  DELMJJ=DELMJJ*4D0*T1G1*T2G2
                ENDIF
              ENDIF
C...If delmjj > delmqq collapse string system to q-qbar q-qbar
C...(Always the case for MSTJ(19)=2 due to initialization above)
              IF (DELMJJ.GT.DELMQQ) THEN
C...Put new system at end of event record
                NCOP=N
                DO 650 IST=1,2
                  DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
                    NCOP=NCOP+1
                    DO 590 IX=1,5
                      P(NCOP,IX)=P(ICOP,IX)
                      K(NCOP,IX)=K(ICOP,IX)
  590               CONTINUE
  600             CONTINUE
                  IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
C...Insert inter-junction gluon string piece (reversed)
                    NJJGL=0
                    DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
                      NJJGL=NJJGL+1
                      NCOP=NCOP+1
                      DO 610 IX=1,5
                        P(NCOP,IX)=P(ICOP,IX)
                        K(NCOP,IX)=K(ICOP,IX)
  610                 CONTINUE
  620               CONTINUE
                    ENDIF
                  IFC=-2*IST+3
                  DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
                    NCOP=NCOP+1
                    DO 630 IX=1,5
                      P(NCOP,IX)=P(ICOP,IX)
                      K(NCOP,IX)=K(ICOP,IX)
  630               CONTINUE
  640             CONTINUE
                  K(NCOP,1)=1
  650           CONTINUE
C...Copy system back in right order
                DO 670 ICOP=NBEG,NEND-2
                  DO 660 IX=1,5
                    P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
                    K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
  660             CONTINUE
  670           CONTINUE
C...Shift down rest of event record
                DO 690 ICOP=NEND+1,N
                  DO 680 IX=1,5
                    P(ICOP-2,IX)=P(ICOP,IX)
                    K(ICOP-2,IX)=K(ICOP,IX)
  680             CONTINUE
  690             CONTINUE
C...Update length of event record.
                N=N-2
              ENDIF
              MJUN1=0
              NBEG=I+1
            ENDIF
  700     CONTINUE
        ENDIF
      ENDIF
 
C...Done if no checks on small-mass systems.
      IF(MSTJ(14).LT.0) RETURN
      IF(MSTJ(14).EQ.0) GOTO 1140
 
C...Find lowest-mass colour singlet jet system.
      NS=N
  710 NSIN=N-NS
      PDMIN=1D0+PARJ(32)
      IC=0
      DO 770 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 720 J=1,4
            DPS(J)=P(I,J)
  720     CONTINUE
          MSTJ(93)=1
          DPS(5)=PYMASS(K(I,2))
        ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
          DO 730 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  730     CONTINUE
          MSTJ(93)=1
          DPS(5)=DPS(5)+PYMASS(K(I,2))
        ELSEIF(K(I,1).EQ.2) THEN
          DO 740 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  740     CONTINUE
        ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
          DO 750 J=1,4
            DPS(J)=DPS(J)+P(I,J)
  750     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 760 J=1,5
              DPC(J)=DPS(J)
  760       CONTINUE
            IC1=IC
            IC2=I
          ENDIF
          IC=0
        ELSE
          NSIN=NSIN+1
        ENDIF
  770 CONTINUE
 
C...Done if lowest-mass system above threshold for string frag.
      IF(PDMIN.GE.PARJ(32)) GOTO 1140
 
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...Find total flavour content - complicated by presence of junctions.
      NQ=0
      NDIQ=0
      DO 780 I=IC1,IC2
        IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
          NQ=NQ+1
          KFQ(NQ)=K(I,2)
          IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
        ENDIF
  780 CONTINUE
 
C...If several diquarks, split up one to give even number of flavours.
      IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
        I1=3
        IF(IABS(KFQ(3)).LT.1000) I1=1
        KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
        KFQ(I1)=KFQ(I1)/1000
        NQ=4
        NDIQ=NDIQ-1
      ENDIF
 
C...If four quark ends, join two to diquark.
      IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
        I1=1
        I2=2
        IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
        IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
        KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
        IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
        KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
     &  100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
        KFQ(I2)=KFQ(4)
        NQ=3
        NDIQ=1
      ENDIF
 
C...If two quark ends, plus quark or diquark, join quarks to diquark.
      IF(NQ.EQ.3) THEN
        I1=1
        I2=2
        IF(IABS(KFQ(I1)).GT.1000) I1=3
        IF(IABS(KFQ(I2)).GT.1000) I2=3
        KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
        IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
        KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
     &  100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
        KFQ(I2)=KFQ(3)
        NQ=2
        NDIQ=NDIQ+1
      ENDIF
 
C...Form two particles from flavours of lowest-mass system, if feasible.
      NTRY = 0
  790 NTRY = NTRY + 1
 
C...Open string with two specified endpoint flavours.
      IF(NQ.EQ.2) THEN
        KC1=PYCOMP(KFQ(1))
        KC2=PYCOMP(KFQ(2))
        IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
        KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
        KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
        IF(KQ1+KQ2.NE.0) GOTO 1140
C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
  800   K1=KFQ(1)
        IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
        MSTU(125)=0
        CALL PYDCYK(K1,0,KFLN,K(N+2,2))
        CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
 
C...Open string with four specified flavours.
      ELSEIF(NQ.EQ.4) THEN
        KC1=PYCOMP(KFQ(1))
        KC2=PYCOMP(KFQ(2))
        KC3=PYCOMP(KFQ(3))
        KC4=PYCOMP(KFQ(4))
        IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
        KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
        KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
        KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
        KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
        IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
C...Combine flavours pairwise to form two hadrons.
  810   I1=1
        I2=2
        IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
     &  IABS(KFQ(2)).GT.1000)) I2=3
        IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
     &  IABS(KFQ(3)).GT.1000))) I2=4
        I3=3
        IF(I2.EQ.3) I3=2
        I4=10-I1-I2-I3
        CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
        CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
        IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
 
C...Closed string.
      ELSE
        IF(IABS(K(IC2,2)).NE.21) GOTO 1140
C...No room for popcorn mesons in closed string -> 2 hadrons.
        MSTU(125)=0
  820   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 820
      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 (if no
C...place to shuffle momentum or too many flavours), or form one hadron.
      IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
        IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
          GOTO 790
        ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
          GOTO 1140
        ELSE
          GOTO 890
        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 830 J=1,4
        P(N+2,J)=P(IC1,J)
  830 CONTINUE
      DO 850 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 840 J=1,4
            P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
  840     CONTINUE
        ENDIF
  850 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)
  860 UE(3)=PYR(0)
      IF(PARJ(21).LE.0.01D0) UE(3)=1D0
      PT2=(1D0-UE(3)**2)*PA**2
      IF(MSTJ(16).LE.0) THEN
        PREV=0.5D0
      ELSE
        IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
        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*PARJ(40))))
      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 870 J=1,3
        P(N+2,J)=PA*UE(J)
        P(N+3,J)=-PA*UE(J)
  870 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 880 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
        V(N+3,J)=V(IC2,J)
  880 CONTINUE
      N=N+3
      GOTO 1120
 
C...Else form one particle, if possible.
  890 NBODY=1
      K(N+1,5)=N+2
      DO 900 J=1,4
        V(N+1,J)=V(IC1,J)
        V(N+2,J)=V(IC1,J)
  900 CONTINUE
 
C...Select hadron flavour from available quark flavours.
  910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
        GOTO 1140
      ELSEIF(NQ.EQ.2) THEN
        CALL PYKFDI(KFQ(1),KFQ(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 910
      P(N+2,5)=PYMASS(K(N+2,2))
 
C...Use old algorithm for E/p conservation? (EN)
      IF (MSTJ(16).LE.0) GOTO 1080
 
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
      NJUNC=0
      DO 940 I1=MAX(1,IP),N-1
        IF(K(I1,1).EQ.1) NJUNC=0
        IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
        IF(K(I1,1).EQ.41) GOTO 940
        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
  920     I2=I2+1
          IF(K(I2,1).EQ.41) GOTO 940
          IF(K(I2,1).GT.10) GOTO 920
          IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
          IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
     &    NJUNC.EQ.0) GOTO 940
          IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
          IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
     &    K(I2,1).NE.1)) GOTO 940
 
C...Define velocity vectors e1, e2, ecl and differences e3, e4.
          DO 930 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)
  930     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
  940 CONTINUE
 
C... Check if there are any strings to connect to the new gluon. (EN)
      IF (IBEG.EQ.0) GOTO 1080
 
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 950 J=1,5
          P(N+2,J)=FRAC*P(N+1,J)
          PG(J)=(1D0-FRAC)*P(N+1,J)
  950   CONTINUE
 
C... Copy string with new gluon put in.
        N=N+2
        I=IBEG-1
  960   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
        N=N+1
        DO 970 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
  970   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 980 J=1,5
            K(N,J)=K(N-1,J)
            P(N,J)=PG(J)
            V(N,J)=V(N-1,J)
  980     CONTINUE
          K(N,2)=21
          K(N,3)=NSAV+1
        ENDIF
        IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
        GOTO 1120
 
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
  990   I=I+1
        IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
        IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
        N=N+1
        DO 1000 J=1,5
          K(N,J)=K(I,J)
          P(N,J)=P(I,J)
          V(N,J)=V(I,J)
 1000   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.OR.K(I,1).EQ.51) GOTO 990
        I2=I1+1
 
C...Set initial Phad.
        DO 1010 J=1,4
          P(NSAV+2,J)=P(NSAV+1,J)
 1010   CONTINUE
 
C...Calculate Pg, a part of which will be added to Phad later. (EN)
 1020   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 1030 J=1,4
          PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
 1030   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.AND.K(I1,2).EQ.21) THEN
          ITER=1
          DO 1040 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
            P(I1,J)=0D0
 1040     CONTINUE
          P(I1,5)=0D0
          K(I1,1)=K(I1,1)+10
          I1=I1-1
          IF(K(I1,1).EQ.41) ITER=-1
        ENDIF
        IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
          ITER=1
          DO 1050 J=1,4
            P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
            P(I2,J)=0D0
 1050     CONTINUE
          P(I2,5)=0D0
          K(I2,1)=K(I2,1)+10
          I2=I2+1
          IF(K(I2,1).EQ.41) ITER=-1
        ENDIF
        IF(ITER.EQ.1) GOTO 1020
 
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).OR.ITER.EQ.-1) THEN
          DO 1060 I=NSAV+3,N
            IM=K(I,3)
            K(IM,1)=K(IM,1)-10
            K(IM,4)=0
            K(IM,5)=0
 1060     CONTINUE
          N=NSAV
          GOTO 1080
        ENDIF
 
C... Construct the collapsed hadron and modified string partons.
        DO 1070 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)
 1070   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 1120
      ENDIF
 
C... Use old algorithm; by choice or when in trouble.
 1080 CONTINUE
C...Find parton/particle which combines to largest extra mass.
      IR=0
      HA=0D0
      HSM=0D0
      DO 1100 MCOMB=1,3
        IF(IR.NE.0) GOTO 1100
        DO 1090 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 1090
          IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
          IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
          IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
          IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
     &    GOTO 1090
          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
 1090   CONTINUE
 1100 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 1110 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)
 1110   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.
 1120 DO 1130 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
        IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
 1130 CONTINUE
      IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
 
C...Check flavours and invariant masses in parton systems.
 1140 NP=0
      KFN=0
      KQS=0
      NJU=0
      DO 1150 J=1,5
        DPS(J)=0D0
 1150 CONTINUE
      DO 1180 I=MAX(1,IP),N
        IF(K(I,1).EQ.41) NJU=NJU+1
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
        KC=PYCOMP(K(I,2))
        IF(KC.EQ.0) GOTO 1180
        KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
        IF(KQ.EQ.0) GOTO 1180
        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 1160 J=1,4
          DPS(J)=DPS(J)+P(I,J)
 1160   CONTINUE
        IF(K(I,1).EQ.1) THEN
          NFERR=0
          IF(NJU.EQ.0.AND.NP.NE.1) THEN
            IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
          ELSEIF(NJU.EQ.1) THEN
            IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
          ELSEIF(NJU.EQ.2) THEN
            IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
          ELSEIF(NJU.GE.3) THEN
            NFERR=1
          ENDIF
          IF(NFERR.EQ.1) THEN
            CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
            MINT(51)=1
            RETURN
          ENDIF
          IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
     &    (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
     &    '(PYPREP:) too small mass in jet system')
          NP=0
          KFN=0
          KQS=0
          NJU=0
          DO 1170 J=1,5
            DPS(J)=0D0
 1170     CONTINUE
        ENDIF
 1180 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(6),PJU(5,5),
     &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
     &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
     &PBST(3,5),TJUOLD(5)
 
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.
      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
      NTRYFN=0
      IJUORI(1)=0
      IJUORI(2)=0
 
C...Identify parton system.
      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.AND.K(I,1).NE.41) 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
        IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
          MJU(1)=N+NP
          IJUORI(1)=I
        ELSE
          MJU(2)=N+NP
          IJUORI(2)=I
        ENDIF
      ENDIF
      IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
      IF(MOD(KQSUM,3).NE.0) THEN
        CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
      IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
 
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
      NTRYWR=0
      PARU12=PARU(12)
      PARU13=PARU(13)
      MJU(3)=MJU(1)
      MJU(4)=MJU(2)
      NR=NP
      NRMIN=2
      IF(MJU(1).GT.0) NRMIN=NRMIN+2
      IF(MJU(2).GT.0) NRMIN=NRMIN+2
  140 IF(NR.GT.NRMIN) 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))
          IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
          DO 190 I=IR+1,N+NR-1
            K(I,1)=K(I+1,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.8.AND.NR.GT.NRMIN) THEN
        PARU12=4D0*PARU12
        PARU13=2D0*PARU13
        GOTO 140
      ELSEIF(NTRY.GT.100.OR.NTRYR.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 650
      IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
     &     ' junction strings not handled by MSTJ(12)>3 options')
      DO 640 JT=1,2
        NJS(JT)=0
        IF(MJU(JT).EQ.0) GOTO 640
        JS=3-2*JT
 
C++SKANDS
C...Find and sum up momentum on three sides of junction.
C...Begin with previous boost = zero.
        IJRFIT=0
        DO 210 IX=1,3
          TJUOLD(IX)=0D0
  210   CONTINUE
C...Prevent IJU (specifically IJU(5)) from containing junk below
        DO 215 IU=1,6
          IJU(IU)=0
 215    CONTINUE
        TJUOLD(4)=1D0
  220   IU=0
C...Beginning and end of string system in event record.
        I1BEG=N+1+(JT-1)*(NR-1)
        I1END=N+NR+(JT-1)*(1-NR)
C...Look for junction string piece end points
        DO 230 I1=I1BEG,I1END,JS
          IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
C...Store junction string piece end points.
C                 1-junction systems        2-junction systems
C           IU :  1     2     3   4     1     2   3     4   5     6
C       IJU(IU):  q-g-g-q-g-g-j-g-q     q-g-g-q-g-j-g-g-j-g-q-g-g-q
            IU=IU+1
            IJU(IU)=I1
          ENDIF
C...Sum over momenta, from junction outwards.
  230   CONTINUE
        DO 280 IU=1,3
          PWT=0D0
C...Initialize junction drag and string piece 4-vectors.
          DO 240 J=1,5
            PBST(IU,J)=0D0
            PJU(IU,J)=0D0
  240     CONTINUE
C...First two branches. Inwards out means opposite direction to JS.
C...(JS is 1 for JT=1, -1 for JT=2)
          IF (IU.LT.3) THEN
            I1A=IJU(IU+1)-JS
            I1B=IJU(IU)
            IDIR=-JS
C...Last branch (gq or gjgqgq). Direction now reversed.
          ELSE
            I1A=IJU(IU)+JS
            I1B=I1END
            IDIR=JS
          ENDIF
          DO 270 I1=I1A,I1B,IDIR
C...Sum up momentum directions with exponential suppression
C...for use in finding junction rest frame below.
            IF (K(I1,2).EQ.88) THEN
C...gjgqgq type system encountered. Use current PWT as start
C...for both strings.
              PWTOLD=PWT
            ELSE
              IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
C...Sum up string piece (boosted) 4-momenta.
              DO 250 J=1,4
                PJU(IU,J)=PJU(IU,J)+P(I1,J)
  250         CONTINUE
C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
C...boost is zero, see above). Skip parton if suppression factor large.
              IF (PWT.GT.10D0) GOTO 270
C...Compute momentum in current frame:
              TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
              BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
              DO 260 J=1,3
                PTMP=P(I1,J)+TJUOLD(J)*BFC
                PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
  260         CONTINUE
C...Boosted energy
              PTMP=TJUOLD(4)*P(I1,4)+TDP
              PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
              PWT=PWT+PTMP/PARJ(48)
            ENDIF
  270     CONTINUE
C...Put |p| rather than m in 5th slot.
          PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
          PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
  280   CONTINUE
 
C...Calculate boost from present frame to next JRF candidate.
        IJRFIT=IJRFIT+1
        CALL PYJURF(PBST,TJU)
 
C...After some iterations do not take full step in new direction.
        IF(IJRFIT.GT.5) THEN
          REDUCE=0.8D0**(IJRFIT-5)
          TJU(1)=REDUCE*TJU(1)
          TJU(2)=REDUCE*TJU(2)
          TJU(3)=REDUCE*TJU(3)
          TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
        ENDIF
 
C...Combine new boost (TJU) with old boost (TJUOLD)
        TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
        DO 290 IX=1,3
          TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
  290   CONTINUE
        TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
 
C...If last boost small, accept JRF, else iterate.
C...Also prevent possibility of infinite loop.
        IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
     &  IJRFIT.LT.MSTJ(18)) THEN
          GOTO 220
        ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
          CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
        ENDIF
 
C...Now store total boost in TJU and change perception.
C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
C...TJU = junction motion vector in string CM, so the sign changes.
        DO 300 J=1,3
          TJU(J)=-TJUOLD(J)
  300   CONTINUE
        TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
 
C--SKANDS
 
C...Calculate string piece energies in junction rest frame.
        DO 310 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)
          PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
     &    TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
  310   CONTINUE
 
C...Start preparing for fragmentation of two strings from junction.
        ISTA=I
        NTRYER=0
  320   NTRYER=NTRYER+1
        I=ISTA
        DO 620 IU=1,2
          NS=IABS(IJU(IU+1)-IJU(IU))
 
C...Junction strings: find longitudinal string directions.
          DO 350 IS=1,NS
            IS1=IJU(IU)+JS*(IS-1)
            IS2=IJU(IU)+JS*IS
            DO 330 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)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
     &        (PJU(IU,5)/PBST(IU,5))
  330       CONTINUE
            IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
     &      PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
            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 340 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)
  340       CONTINUE
  350     CONTINUE
 
C...Junction strings: initialize flavour, momentum and starting pos.
          ISAV=I
          MSTU91=MSTU(90)
  360     NTRY=NTRY+1
          IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) 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)
          IF (MOD(JT+IU,2).NE.0) THEN
            IE(1)=K(IJU(IU),3)
            IF (NP-NR.NE.0) THEN
C...If gluons have disappeared. Original IJU must be used.
              IT=IP
              NE=1
  370         IT=IT+1
              IF (K(IT,2).NE.21) THEN
                NE=NE+1
              ENDIF
              IF (NE.EQ.IU+4*(JT-1)) THEN
                IE(1)=IT
              ELSEIF (IT.LE.IP+NP) THEN
                GOTO 370
              ELSE
                CALL PYERRM(14,'(PYSTRF:) '//
     &               'Original IJU could not be reconstructed!')
              ENDIF
            ENDIF
          ENDIF
          IN(4)=N+NR+1
          IN(5)=IN(4)+1
          IN(6)=N+NR+4*NS+1
          DO 390 JQ=1,2
            DO 380 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
  380       CONTINUE
  390     CONTINUE
          KFL(1)=K(IJU(IU),2)
          PX(1)=0D0
          PY(1)=0D0
          GAM(1)=0D0
          DO 400 J=1,5
            PJU(IU+3,J)=0D0
  400     CONTINUE
 
C...Junction strings: find initial transverse directions.
          DO 410 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
  410     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 420 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))
  420     CONTINUE
 
C...Junction strings: produce new particle, origin.
  430     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.
  440     CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
          IF(K(I,2).EQ.0) GOTO 360
          IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
     &    IABS(KFL(3)).GT.10) THEN
            IF(PYR(0).GT.PARJ(19)) GOTO 440
          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 450 J=1,3
            IN(J)=IN(3+J)
  450     CONTINUE
 
C...Junction strings: stepping within 'low' string region.
          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 460 J=1,4
              P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
  460       CONTINUE
            GOTO 560
C...Has used up energy of junction string, i.e. no more hadrons in it.
          ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
            DO 470 J=1,5
              P(I,J)=0D0
  470       CONTINUE
            GOTO 600
C...Stepping from 'low' string region
          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 360
            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.
  480     IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
     &    IN(1).GT.IN(2)) GOTO 360
          IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
            DO 490 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
  490       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 480
            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 500 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))
  500       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 530 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 510 IN1=IN(4),IN(1)-4,4
              P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
  510       CONTINUE
            DO 520 IN2=IN(5),IN(2)-4,4
              P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
  520       CONTINUE
  530     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 550 IN2=IN(1)+1,IN(2),4
            DO 540 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
  540       CONTINUE
  550     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 360
          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 360
          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 360
            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 480
          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)+4
            GOTO 480
          ENDIF
 
C...Junction strings: particle four-momentum, remainder, loop back.
  560     DO 570 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)
  570     CONTINUE
          IF(P(I,4).LT.P(I,5)) GOTO 360
          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 580 J=1,4
                P(IN(6),J)=P(IN(3),J)
                P(IN(6)+1,J)=P(IN(3)+1,J)
  580         CONTINUE
            ENDIF
            DO 590 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)
  590       CONTINUE
            GOTO 430
          ENDIF
 
C...Junction strings: save quantities left after each string.
          IF(IABS(KFL(1)).GT.10) GOTO 360
  600     I=I-1
          KFJH(IU)=KFL(1)
          DO 610 J=1,4
            PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
  610     CONTINUE
 
C...Junction strings: loopback if much unused energy in both strings.
          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)
          EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
  620   CONTINUE
        IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
     &  EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
     &  EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
     &  .AND.NTRYER.LT.10) GOTO 320
 
C...Junction strings: put together to new effective string endpoint.
        NJS(JT)=I-ISTA
        KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
        IF(KFJH(1).EQ.KFJH(2)) KFLS=3
        KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
     &  100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
        DO 630 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)
  630   CONTINUE
        PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
     &  PJS(JT,3)**2))
        PJS(JT+2,5)=0D0
  640 CONTINUE
 
C...Open versus closed strings. Choose breakup region for latter.
  650 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 660 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)
  660   CONTINUE
        W2RAN=PYR(0)*W2SUM
        NB=0
  670   NB=NB+1
        W2SUM=W2SUM-P(N+NR+NB,1)
        IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
      ENDIF
 
C...Find longitudinal string directions (i.e. lightlike four-vectors).
      DO 700 IS=1,NS
        IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
        IS2=N+IS+NB-NR*((IS+NB-1)/NR)
        DO 680 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)
  680   CONTINUE
        IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
     &  DP(1,2)**2-DP(1,3)**2))
        IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
     &  DP(2,2)**2-DP(2,3)**2))
        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) GOTO 200
        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 690 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)
  690   CONTINUE
  700 CONTINUE
 
C...Begin initialization: sum up energy, set starting position.
      ISAV=I
      MSTU91=MSTU(90)
  710 NTRY=NTRY+1
      IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) 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 730 J=1,4
        P(N+NRS,J)=0D0
        DO 720 IS=1,NR
          P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
  720   CONTINUE
  730 CONTINUE
      DO 750 JT=1,2
        IRANK(JT)=0
        IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
        IF(NS.GT.NR) IRANK(JT)=1
        IBARRK(JT)=0
        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 740 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
  740   CONTINUE
  750 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 760 JT=1,2
          KFL(JT)=K(IE(JT),2)
          IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
          IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
          MSTJ(93)=1
          PMQ(JT)=PYMASS(KFL(JT))
          GAM(JT)=0D0
  760   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
  770   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 770
        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)
  780   CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
        ZR=PR3/(Z*P(N+NR+1,5)**2)
        IF(ZR.GE.1D0) GOTO 780
        DO 790 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
  790   CONTINUE
      ENDIF
C.. MOPS variables
      DO 800 JT=1,2
         XTMO(JT)=1D0
         PM2QMO(JT)=PMQ(JT)**2
         IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
  800 CONTINUE
 
C...Find initial transverse directions (i.e. spacelike four-vectors).
      DO 840 JT=1,2
        IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
          IN1=IN(3*JT+1)
          IN3=IN(3*JT+3)
          DO 810 J=1,4
            DP(1,J)=P(IN1,J)
            DP(2,J)=P(IN1+1,J)
            DP(3,J)=0D0
            DP(4,J)=0D0
  810     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 820 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))
  820     CONTINUE
        ELSE
          DO 830 J=1,4
            P(IN3+2,J)=P(IN3,J)
            P(IN3+3,J)=P(IN3+1,J)
  830     CONTINUE
        ENDIF
  840 CONTINUE
 
C...Remove energy used up in junction string fragmentation.
      IF(MJU(1)+MJU(2).GT.0) THEN
        DO 860 JT=1,2
          IF(NJS(JT).EQ.0) GOTO 860
          DO 850 J=1,4
            P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
  850     CONTINUE
  860   CONTINUE
        PARJST=PARJ(33)
        IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
        WMIN=PARJST+PMQ(1)+PMQ(2)
        WREM2=FOUR(N+NRS,N+NRS)
        IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
          NTRYWR=NTRYWR+1
          IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
          GOTO 140
        ENDIF
      ENDIF
 
C...Produce new particle: side, origin.
  870 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,4)=0
      K(I,5)=0
 
C...Generate flavour, hadron and pT.
  880 K(I,3)=IE(JT)
      CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
      IF(K(I,2).EQ.0) GOTO 710
      MU90MO=MSTU(90)
      IF(MSTU(121).EQ.-1) GOTO 910
      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 880
      ENDIF
      IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
     &K(I,3)=IJUORI(JT)
      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 710
      IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
     &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
 
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 1080
      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 900 J=1,9
                  IF(J.LE.5) THEN
                     DO 890 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)
  890                CONTINUE
                  ENDIF
                  INMO(J)=IN(J)
  900          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
  910 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 880
         I=IMO
         KFL(JT)=KFLMO
         PMQ(JT)=PMQMO
         PX(JT)=PXMO
         PY(JT)=PYMO
         GAM(JT)=GAMMO
         IRANK(JT)=IRMO
         XTMO(JT)=XMO
         DO 930 J=1,9
            IF(J.LE.5) THEN
               DO 920 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)
  920          CONTINUE
            ENDIF
            IN(J)=INMO(J)
  930    CONTINUE
         GOTO 880
      ENDIF
      XTMO(JT)=XTMO3
C.. MOPS end of modification
 
      DO 940 J=1,3
        IN(J)=IN(3*JT+J)
  940 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 950 J=1,4
          P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
  950   CONTINUE
        GOTO 1040
      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 710
        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).
  960 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 710
      IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
        DO 970 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
  970   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 960
        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 980 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))
  980   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 1010 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 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
          P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
  990   CONTINUE
        DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
          P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
 1000   CONTINUE
 1010 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 1030 IN2=IN(1)+1,IN(2),4
        DO 1020 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
 1020   CONTINUE
 1030 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 710
      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 710
      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 710
        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 960
      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 960
      ENDIF
 
C...Four-momentum of particle. Remaining quantities. Loop back.
 1040 DO 1050 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)
 1050 CONTINUE
      IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
     &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
     &GOTO 200
      IF(P(I,4).LT.P(I,5)) GOTO 710
      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 1060 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)
 1060   CONTINUE
      ENDIF
      DO 1070 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)
 1070 CONTINUE
      IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
     &IBARRK(JT)=0
      GOTO 870
 
C...Final hadron: side, flavour, hadron, mass.
 1080 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 710
      IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
     &IBARRK(JT)=0
      IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
     &K(I,3)=IJUORI(JT)
      IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
     &K(I,3)=IJUORI(JR)
      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=2D0*DHR1*DHR2*DHC12
      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 710
      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*PARJ(40))))
      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 1090 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)
 1090 CONTINUE
      IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
      DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2
      DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
      IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
        NTRYFN=NTRYFN+1
        IF(NTRYFN.LT.100) GOTO 140
        CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
      ENDIF
 
C...Mark jets as fragmented and give daughter pointers.
      N=I-NRS+1
      DO 1100 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
 1100 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 1110 J=1,4
        P(NSAV,J)=DPS(J)
        V(NSAV,J)=V(IP,J)
 1110 CONTINUE
      P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
      V(NSAV,5)=0D0
      DO 1130 I=NSAV+1,N
        DO 1120 J=1,5
          K(I,J)=K(I+NRS-1,J)
          P(I,J)=P(I+NRS-1,J)
          V(I,J)=0D0
 1120   CONTINUE
 1130 CONTINUE
      MSTU91=MSTU(90)
      DO 1140 IZ=MSTU90+1,MSTU91
        MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
        PARU9T(IZ)=PARU(90+IZ)
 1140 CONTINUE
      MSTU(90)=MSTU90
 
C...Order particles in rank along the chain. Update mother pointer.
      DO 1160 I=NSAV+1,N
        DO 1150 J=1,5
          K(I-NSAV+N,J)=K(I,J)
          P(I-NSAV+N,J)=P(I,J)
 1150   CONTINUE
 1160 CONTINUE
      I1=NSAV
      DO 1190 I=N+1,2*N-NSAV
        IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
        I1=I1+1
        DO 1170 J=1,5
          K(I1,J)=K(I,J)
          P(I1,J)=P(I,J)
 1170   CONTINUE
        IF(MSTU(16).NE.2) K(I1,3)=NSAV
        DO 1180 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
 1180   CONTINUE
 1190 CONTINUE
      DO 1220 I=2*N-NSAV,N+1,-1
        IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
        I1=I1+1
        DO 1200 J=1,5
          K(I1,J)=K(I,J)
          P(I1,J)=P(I,J)
 1200   CONTINUE
        IF(MSTU(16).NE.2) K(I1,3)=NSAV
        DO 1210 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
 1210   CONTINUE
 1220 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 1230 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
 1230   CONTINUE
      ENDIF
      DO 1250 I=NSAV+1,N
        DO 1240 J=1,4
          V(I,J)=V(IP,J)
 1240   CONTINUE
 1250 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYJURF
C...From three given input vectors in PJU the boost VJU from
C...the "lab frame" to the junction rest frame is constructed.
 
      SUBROUTINE PYJURF(PJU,VJU)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...Input, output and local arrays.
      DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
      DATA TWOPI/6.283186D0/
 
C...Calculate masses and other invariants.
      DO 100 J=1,4
        PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
  100 CONTINUE
      PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
      PSUM(5)=SQRT(PSUM2)
      DO 120 I=1,3
        DO 110 J=1,3
          A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
     &    PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
  110   CONTINUE
  120 CONTINUE
 
C...Pick I to be most massive parton and J to be the one closest to I.
      ITRY=0
      I=1
      IF(A(2,2).GT.A(1,1)) I=2
      IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
  130 ITRY=ITRY+1
      J=1+MOD(I,3)
      K=1+MOD(J,3)
      IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
        K=1+MOD(I,3)
        J=1+MOD(K,3)
      ENDIF
      PMI2=A(I,I)
      PMJ2=A(J,J)
      PMK2=A(K,K)
      AIJ=A(I,J)
      AIK=A(I,K)
      AJK=A(J,K)
 
C...Trivial find new parton energies if all three partons are massless.
      IF(PMI2.LT.1D-4) THEN
        PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
        PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
        PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
 
C...Else find momentum range for parton I and values at extremes.
      ELSE
        PAIMIN=0D0
        PEIMIN=SQRT(PMI2)
        PEJMIN=AIJ/PEIMIN
        PEKMIN=AIK/PEIMIN
        PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
        PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
        FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
        PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
        IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
        PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
        HI=PEIMAX**2-0.25D0*PAIMAX**2
        PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
     &  0.5D0*PAIMAX*AIJ)/HI
        PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
     &  0.5D0*PAIMAX*AIK)/HI
        PEJMAX=SQRT(PAJMAX**2+PMJ2)
        PEKMAX=SQRT(PAKMAX**2+PMK2)
        FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
 
C...If unexpected values at upper endpoint then pick another parton.
        IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
          I1=1+MOD(I,3)
          IF(A(I1,I1).GE.1D-4) THEN
            I=I1
            GOTO 130
          ENDIF
          ITRY=ITRY+1
          I1=1+MOD(I,3)
          IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
            I=I1
            GOTO 130
          ENDIF
        ENDIF
 
C..Start binary + linear search to find solution inside range.
        ITER=0
        ITMIN=0
        ITMAX=0
        PAI=0.5D0*(PAIMIN+PAIMAX)
  140   ITER=ITER+1
 
C...Derive momentum of other two partons and distance to root.
        PEI=SQRT(PAI**2+PMI2)
        HI=PEI**2-0.25D0*PAI**2
        PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
        PEJ=SQRT(PAJ**2+PMJ2)
        PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
        PEK=SQRT(PAK**2+PMK2)
        FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
 
C...Pick next I momentum to explore, hopefully closer to root.
        IF(FNOW.GT.0D0) THEN
          PAIMIN=PAI
          FMIN=FNOW
          ITMIN=ITMIN+1
        ELSE
          PAIMAX=PAI
          FMAX=FNOW
          ITMAX=ITMAX+1
        ENDIF
        IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
     &  THEN
          PAI=0.5D0*(PAIMIN+PAIMAX)
          GOTO 140
        ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
     &  ABS(FNOW).GT.1D-12*PSUM2) THEN
          PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
          GOTO 140
        ENDIF
      ENDIF
 
C...Now know energies in junction rest frame.
      PENEW(I)=PEI
      PENEW(J)=PEJ
      PENEW(K)=PEK
 
C...Boost (copy of) partons to their rest frame.
      VXCM=-PSUM(1)/PSUM(5)
      VYCM=-PSUM(2)/PSUM(5)
      VZCM=-PSUM(3)/PSUM(5)
      GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
      DO 150 I=1,3
        FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
        FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
        PCM(I,1)=PJU(I,1)+FAC2*VXCM
        PCM(I,2)=PJU(I,2)+FAC2*VYCM
        PCM(I,3)=PJU(I,3)+FAC2*VZCM
        PCM(I,4)=PJU(I,4)*GAMCM+FAC1
        PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
  150 CONTINUE
 
C...Construct difference vectors and boost to junction rest frame.
      DO 160 J=1,3
        PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
        PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
  160 CONTINUE
      PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
      PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
      PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
      PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
      PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
      C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
      C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
      VXJU=C4*PCM(4,1)+C5*PCM(5,1)
      VYJU=C4*PCM(4,2)+C5*PCM(5,2)
      VZJU=C4*PCM(4,3)+C5*PCM(5,3)
      GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
 
C...Add two boosts, giving final result.
      FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
      VJU(1)=VXJU+FCM*VXCM
      VJU(2)=VYJU+FCM*VYCM
      VJU(3)=VZJU+FCM*VZCM
      VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
      VJU(5)=1D0
 
C...In case of error in reconstruction: revert to CM frame of system.
      CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
     &(PCM(1,5)*PCM(2,5))
      CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
     &(PCM(1,5)*PCM(3,5))
      CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
     &(PCM(2,5)*PCM(3,5))
      ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
      ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
      DO 170 I=1,3
        FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
        FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
        PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
        PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
        PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
        PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
        PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
  170 CONTINUE
      CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
     &(PCM(1,5)*PCM(2,5))
      CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
     &(PCM(1,5)*PCM(3,5))
      CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
     &(PCM(2,5)*PCM(3,5))
      ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
      ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
      IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
        VJU(1)=VXCM
        VJU(2)=VYCM
        VJU(3)=VZCM
        VJU(4)=GAMCM
      ENDIF
 
      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(8000,2),BRAT(8000),KFDP(8000,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
        IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
        IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
        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).GE.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.EQ.4.OR.KFLH.EQ.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
        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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      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 /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
C...Local arrays.
      DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
     &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
     &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
     &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
     &IREF(1000)
 
C...Check that QMAX not too low.
      IF(MSTJ(41).LE.0) THEN
        RETURN
      ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
        IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
      ELSE
        IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
     &  RETURN
      ENDIF
 
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.-80) THEN
        NPA=IABS(IP2)
        DO 100 I=1,NPA
          IPA(I)=IP1+I-1
  100   CONTINUE
      ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
     &IP2.EQ.-100) 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...Send off to PYPTFS for pT-ordered evolution if requested,
C...if at least 2 partons, and without predefined shower branchings.
      IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
     &MPSPD.EQ.0) THEN
        NPART=NPA
        DO 110 II=1,NPART
          IPART(II)=IPA(II)
          PTPART(II)=0.5D0*QMAX
  110   CONTINUE
        CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
        RETURN
      ENDIF
 
C...Initialization of cutoff masses etc.
      DO 120 IFL=0,40
        ISCOL(IFL)=0
        ISCHG(IFL)=0
        KSH(IFL)=0
  120 CONTINUE
      ISCOL(21)=1
      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 130 IFL=1,5
        ISCOL(IFL)=1
        IF(MSTJ(41).GE.2) ISCHG(IFL)=1
        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)
  130 CONTINUE
      DO 140 IFL=11,15,2
        IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
        IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) 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)
  140 CONTINUE
      PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
      ALAMS=PARJ(81)**2
      ALFM=LOG(PT2MIN/ALAMS)
 
C...Check on phase space available for emission.
      IREJ=0
      DO 150 J=1,5
        PS(J)=0D0
  150 CONTINUE
      PM=0D0
      KFLA(2)=0
      DO 170 I=1,NPA
        KFLA(I)=IABS(K(IPA(I),2))
        PMA(I)=P(IPA(I),5)
C...Special cutoff masses for initial partons (may be a heavy quark,
C...squark, ..., and need not be on the mass shell).
        IR=30+I
        IF(NPA.LE.1) IREF(I)=IR
        IF(NPA.GE.2) IREF(I+1)=IR
        ISCOL(IR)=0
        ISCHG(IR)=0
        KSH(IR)=0
        IF(KFLA(I).LE.8) THEN
          ISCOL(IR)=1
          IF(MSTJ(41).GE.2) ISCHG(IR)=1
        ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
     &  KFLA(I).EQ.17) THEN
          IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
        ELSEIF(KFLA(I).EQ.21) THEN
          ISCOL(IR)=1
        ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
     &  (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
          ISCOL(IR)=1
        ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
          ISCOL(IR)=1
C...QUARKONIA+++
C...same for QQ~[3S18]
        ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
     &  KFLA(I).EQ.9900553)) THEN
          ISCOL(IR)=1
C...QUARKONIA---
        ENDIF

C...Option to switch off radiation from particle KF = MSTJ(39) entirely
C...(only intended for studying the effects of switching such rad on/off)
        IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
          ISCOL(IR)=0
          ISCHG(IR)=0
        ENDIF

        IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
        PMTH(1,IR)=PMA(I)
        IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
          PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
          PMTH(3,IR)=PMTH(2,IR)+PMQTH2
          PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
          PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
        ELSEIF(ISCOL(IR).EQ.1) THEN
          PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
          PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
          PMTH(4,IR)=PMTH(3,IR)
          PMTH(5,IR)=PMTH(3,IR)
        ELSEIF(ISCHG(IR).EQ.1) THEN
          PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
          PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
          PMTH(4,IR)=PMTH(3,IR)
          PMTH(5,IR)=PMTH(3,IR)
        ENDIF
        IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
        PM=PM+PMA(I)
        IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
        DO 160 J=1,4
          PS(J)=PS(J)+P(IPA(I),J)
  160   CONTINUE
  170 CONTINUE
      IF(IREJ.EQ.NPA.AND.IP2.GE.-7) 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...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
      KFSRCE=0
      IF(IP2.LE.0) THEN
      ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
        KFSRCE=IABS(K(K(IP1,3),2))
      ELSE
        IPAR1=MAX(1,K(IP1,3))
        IPAR2=MAX(1,K(IP2,3))
        IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
     &       KFSRCE=IABS(K(K(IPAR1,3),2))
      ENDIF
      ITYPES=0
      IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
      IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
      IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
      IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
      IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
      IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
      IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
      IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
 
C...Identify two primary showerers.
      ITYPE1=0
      IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
      IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
      IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
      IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
      IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
      IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
      IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
      IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
      ITYPE2=0
      IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
      IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
      IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
      IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
      IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
      IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
      IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
      IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
 
C...Order of showerers. Presence of gluino.
      ITYPMN=MIN(ITYPE1,ITYPE2)
      ITYPMX=MAX(ITYPE1,ITYPE2)
      IORD=1
      IF(ITYPE1.GT.ITYPE2) IORD=2
      IGLUI=0
      IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
 
C...Check if 3-jet matrix elements to be used.
      M3JC=0
      ALPHA=0.5D0
      IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
        IF(MSTJ(38).NE.0) THEN
          M3JC=MSTJ(38)
          ALPHA=PARJ(80)
          MSTJ(38)=0
        ELSEIF(MSTJ(47).GE.6) THEN
          M3JC=MSTJ(47)
        ELSE
          ICLASS=1
          ICOMBI=4
 
C...Vector/axial vector -> q + qbar; q -> q + V.
          IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.3)) THEN
            ICLASS=2
            IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
              ICOMBI=1
            ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
     &      K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
C...gamma*/Z0: assume e+e- initial state if unknown.
              EI=-1D0
              IF(KFSRCE.EQ.23) THEN
                IANNFL=K(K(IP1,3),3)
                IF(IANNFL.NE.0) THEN
                  KANNFL=IABS(K(IANNFL,2))
                  IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
                ENDIF
              ENDIF
              AI=SIGN(1D0,EI+0.1D0)
              VI=AI-4D0*EI*PARU(102)
              EF=KCHG(KFLA(1),1)/3D0
              AF=SIGN(1D0,EF+0.1D0)
              VF=AF-4D0*EF*PARU(102)
              XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
              SH=PS(5)**2
              SQMZ=PMAS(23,1)**2
              SQWZ=PS(5)*PMAS(23,2)
              SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
              VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
     &        (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
              AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
              ICOMBI=3
              ALPHA=VECT/(VECT+AXIV)
            ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
              ICOMBI=4
            ENDIF
C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
            ICLASS=2
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=3
 
C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
            ICLASS=4
            IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
              ICOMBI=1
            ELSEIF(KFSRCE.EQ.36) THEN
              ICOMBI=2
            ENDIF
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=5
 
C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.3)) THEN
            ICLASS=6
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=7
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
            ICLASS=8
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=9
 
C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.5)) THEN
            ICLASS=10
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=11
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=12
 
C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
            ICLASS=13
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=14
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=15
 
C...g -> ~g + ~g (eikonal approximation).
          ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
            ICLASS=16
          ENDIF
          M3JC=5*ICLASS+ICOMBI
        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.KFSRCE.EQ.0
     &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
      IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
     &MIIS=MSTJ(50)-3
      IF(MIIS.NE.0) THEN
        DO 190 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 180 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
  180       CONTINUE
          ENDIF
  190   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 210 I=1,2
          DO 200 J=1,5
            K(N+I,J)=K(IPA(I),J)
            P(N+I,J)=P(IPA(I),J)
            V(N+I,J)=0D0
  200     CONTINUE
  210   CONTINUE
        DO 230 I=3,2+NIIS(1)
          DO 220 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
  220     CONTINUE
  230   CONTINUE
        DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
          DO 240 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
  240     CONTINUE
  250   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 260 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))
  260   CONTINUE
        DO 270 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))
  270   CONTINUE
      ENDIF
 
C...Boost 3 or more partons to their rest frame.
      IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
     &-PS(2)/PS(4),-PS(3)/PS(4))
 
C...Define imagined single initiator of shower for parton system.
      NS=N
      IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
        CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
        IF(MSTU(21).GE.1) RETURN
      ENDIF
  280 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
        IREF(1)=21
      ENDIF
 
C...Loop over partons that may branch.
      NEP=NPA
      IM=NS
      IF(NPA.EQ.1) IM=NS-1
  290 IM=IM+1
      IF(N.GT.NS) THEN
        IF(IM.GT.N) GOTO 600
        KFLM=IABS(K(IM,2))
        IR=IREF(IM-NS)
        IF(KSH(IR).EQ.0) GOTO 290
        IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
        IGM=K(IM,3)
      ELSE
        IGM=-1
      ENDIF
      IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) 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 300 I=1,NEP
          K(N+I,3)=IM
  300   CONTINUE
      ELSE
        K(N+1,3)=IPA(1)
      ENDIF
      IF(IGM.LE.0) THEN
        DO 310 I=1,NEP
          K(N+I,2)=K(IPA(I),2)
  310   CONTINUE
      ELSEIF(KFLM.NE.21) THEN
        K(N+1,2)=K(IM,2)
        K(N+2,2)=K(IM,5)
        IREF(N+1-NS)=IREF(IM-NS)
        IREF(N+2-NS)=IABS(K(N+2,2))
      ELSEIF(K(IM,5).EQ.21) THEN
        K(N+1,2)=21
        K(N+2,2)=21
        IREF(N+1-NS)=21
        IREF(N+2-NS)=21
      ELSE
        K(N+1,2)=K(IM,5)
        K(N+2,2)=-K(IM,5)
        IREF(N+1-NS)=IABS(K(N+1,2))
        IREF(N+2-NS)=IABS(K(N+2,2))
      ENDIF
 
C...Reset flags on daughters and tries made.
      DO 320 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(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
  320 CONTINUE
      ISLM=0
 
C...Maximum virtuality of daughters.
      IF(IGM.LE.0) THEN
        DO 330 I=1,NPA
          IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
          P(N+I,5)=MIN(QMAX,PS(5))
          IR=IREF(N+I-NS)
          IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
          IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
  330   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 340 I=1,NEP
        PMSD(I)=P(N+I,5)
        IF(ISI(I).EQ.1) THEN
          IR=IREF(N+I-NS)
          IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
        ENDIF
        V(N+I,5)=P(N+I,5)**2
  340 CONTINUE
 
C...Choose one of the daughters for evolution.
  350 INUM=0
      IF(NEP.EQ.1) INUM=1
      DO 360 I=1,NEP
        IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
  360 CONTINUE
      DO 370 I=1,NEP
        IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
          IR=IREF(N+I-NS)
          IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
        ENDIF
  370 CONTINUE
      IF(INUM.EQ.0) THEN
        RMAX=0D0
        DO 380 I=1,NEP
          IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
            RPM=P(N+I,5)/PMSD(I)
            IR=IREF(N+I-NS)
            IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
              RMAX=RPM
              INUM=I
            ENDIF
          ENDIF
  380   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 390 I=2,NEP
        IEP(I)=IEP(I-1)+1
        IF(IEP(I).GT.N+NEP) IEP(I)=N+1
  390 CONTINUE
      DO 400 I=1,NEP
        KFL(I)=IABS(K(IEP(I),2))
  400 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
      IR=IREF(IEP(1)-NS)
      IF(KSH(IR).EQ.0) GOTO 450
      IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
 
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
      IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
        ISSET(INUM)=0
        IF(IPSPD.NE.0) ISSET(INUM)=1
      ENDIF
 
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(ISCOL(IR).EQ.0) 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(ISCOL(IR).EQ.0) 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,IR)
        V(IEP(1),5)=P(IEP(1),5)**2
        GOTO 450
      ENDIF
 
C...Integral of Altarelli-Parisi z kernel for QCD.
C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
      IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
        FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
C...QUARKONIA+++
C...Evolution of QQ~[3S18] state if MSTP(148)=1.
      ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
     &       (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
        FBR=6D0*LOG((1D0-ZC)/ZC)
C...QUARKONIA---
      ELSEIF(MSTJ(49).EQ.0) THEN
        FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
        IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
 
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.GE.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 colourless.
      IF(ISCOL(IR).EQ.0) FBR=0D0
 
C...Integral of Altarelli-Parisi kernel for photon emission.
      FBRE=0D0
      IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
        IF(KFL(1).LE.18) THEN
          FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
        ENDIF
        IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
      ENDIF
 
C...Inner veto algorithm starts. Find maximum mass for evolution.
  410 PMS=V(IEP(1),5)
      IF(IGM.GE.0) THEN
        PM2=0D0
        DO 420 I=2,NEP
          PM=P(IEP(I),5)
          IRI=IREF(IEP(I)-NS)
          IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
          PM2=PM2+PM
  420   CONTINUE
        PMS=MIN(PMS,(P(IM,5)-PM2)**2)
      ENDIF
 
C...Select mass for daughter in QCD evolution.
      B0=27D0/6D0
      DO 430 IFF=4,MSTJ(45)
        IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
  430 CONTINUE
C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
      PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
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=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
      ELSEIF(MSTJ(44).EQ.1) THEN
        PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
      ELSE
        PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
      ENDIF
C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
      IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
      IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
      V(IEP(1),5)=PMSQCD
      MCE=1
 
C...Select mass for daughter in QED evolution.
      IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
        PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
        IF(FBRE.LT.1D-3) THEN
          PMSQED=0D0
        ELSE
          PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
     &    (PARU(101)*FBRE)))
        ENDIF
C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
        PMSQED=PMSQED+PMTH(1,IR)**2
        IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
     &  PMTH(2,IR)**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,IR)) THEN
        P(IEP(1),5)=PMTH(1,IR)
        V(IEP(1),5)=P(IEP(1),5)**2
        GOTO 450
      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 410
        K(IEP(1),5)=22
 
C...QUARKONIA+++
C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
      ELSEIF(MSTJ(49).EQ.0.AND.
     &       (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
        Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
        IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
        IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
        K(IEP(1),5)=21
C...QUARKONIA---
 
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)
C...Only do z weighting when no ME correction afterwards.
        IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
        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 410
        K(IEP(1),5)=21
      ELSEIF(MSTJ(49).NE.1) THEN
        Z=PYR(0)
        IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
        KFLB=1+INT(MSTJ(45)*PYR(0))
        PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
        IF(PMQ.GE.1D0) GOTO 410
        IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
          IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
          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 410
        ELSE
          IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
        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 410
        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.OR.MSTJ(44).EQ.5)) THEN
          IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
        ELSE
          PT2APP=Z*(1D0-Z)*V(IEP(1),5)
          IF(MSTJ(44).GE.4) PT2APP=PT2APP*
     &    (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
          IF(PT2APP.LT.PT2MIN) GOTO 410
          IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
        ENDIF
      ENDIF
 
C...Check if z consistent with chosen m.
      IF(KFL(1).EQ.21) THEN
        IRGD1=IABS(K(IEP(1),5))
        IRGD2=IRGD1
      ELSE
        IRGD1=IR
        IRGD2=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
        PMQTH3=0.5D0*PARJ(82)
        IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
        IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
        PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
        PMQ2=(PMTH(1,IRGD2)**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.OR.MSTJ(44).EQ.5)) 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 410
      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 410
        ELSEIF(MSTJ(40).EQ.2) THEN
          IF(1D0-CHI.LT.PYR(0)) GOTO 410
        ENDIF
      ENDIF
 
C...Three-jet matrix element correction.
      IF(M3JC.GE.1) THEN
        WME=1D0
        WSHOW=1D0
 
C...QED matrix elements: only for massless case so far.
        IF(MCE.EQ.2.AND.IGM.EQ.0) 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)
          KI1=K(IPA(INUM),2)
          KI2=K(IPA(3-INUM),2)
          QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
          QF2=KCHG(PYCOMP(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(MCE.EQ.2) THEN
 
C...QCD matrix elements, including mass effects.
        ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
          PS1ME=V(IEP(1),5)
          PM1ME=PMTH(1,IR)
          M3JCC=M3JC
          IF(IR.GE.31.AND.IGM.EQ.0) THEN
C...QCD ME: original parton, first branching.
            PM2ME=PMTH(1,63-IR)
            ECMME=PS(5)
          ELSEIF(IR.GE.31) THEN
C...QCD ME: original parton, subsequent branchings.
            PM2ME=PMTH(1,63-IR)
            PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
            ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
          ELSEIF(K(IM,2).EQ.21) THEN
C...QCD ME: secondary partons, first branching.
            PM2ME=PM1ME
            ZMME=V(IM,1)
            IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
            PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
     &      4D0*PS1ME*PM2ME**2))
            PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
     &      V(IM,5)
            ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
            M3JCC=66
          ELSE
C...QCD ME: secondary partons, subsequent branchings.
            PM2ME=PM1ME
            PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
            ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
            M3JCC=66
          ENDIF
C...Construct ME variables.
          R1ME=PM1ME/ECMME
          R2ME=PM2ME/ECMME
          X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
          X2=1D0+R2ME**2-PS1ME/ECMME**2
C...Call ME, with right order important for two inequivalent showerers.
          IF(IR.EQ.IORD+30) THEN
            WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
          ELSE
            WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
          ENDIF
C...Split up total ME when two radiating partons.
          ISPRAD=1
          IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
     &    (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
     &    (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
     &    (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
     &    (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
          IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
     &    MAX(1D-10,2D0-X1-X2)
C...Evaluate shower rate to be compared with.
          WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
     &    MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
          IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
        ELSEIF(MSTJ(49).NE.1) THEN
 
C...Toy model scalar theory matrix elements; no mass effects.
        ELSE
          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)
          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 410
      ENDIF
 
C...Impose angular ordering by rejection of nonordered emission.
      IF(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(IR.GE.31.AND.MSTJ(42).GE.5) THEN
          MAOD=0
        ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
     &  .OR.MSTJ(42).EQ.7)) THEN
          MAOD=0
        ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
     &  .OR.MSTJ(42).EQ.6)) 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)
          IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
     &    (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
        ENDIF
        MAOM=1
        IAOM=IM
  440   IF(K(IAOM,5).EQ.22) THEN
          IAOM=K(IAOM,3)
          IF(K(IAOM,3).LE.NS) MAOM=0
          IF(MAOM.EQ.1) GOTO 440
        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 410
        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 410
        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 410
        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 410
        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 410
        ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
          IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
        ENDIF
      ENDIF
 
C...End of inner veto algorithm. Check if only one leg evolved so far.
  450 V(IEP(1),1)=Z
      ISL(1)=0
      ISL(2)=0
      IF(NEP.EQ.1) GOTO 490
      IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
      DO 460 I=1,NEP
        IR=IREF(N+I-NS)
        IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
          IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
        ENDIF
  460 CONTINUE
 
C...Check if chosen multiplet m1,m2,z1,z2 is physical.
      IF(NEP.GE.3) THEN
        PMSUM=0D0
        DO 470 I=1,NEP
          PMSUM=PMSUM+P(N+I,5)
  470   CONTINUE
        IF(PMSUM.GE.PS(5)) GOTO 350
      ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
        DO 480 I1=N+1,N+2
          IRDA=IREF(I1-NS)
          IF(KSH(IRDA).EQ.0) GOTO 480
          IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
          IF(IRDA.EQ.21) THEN
            IRGD1=IABS(K(I1,5))
            IRGD2=IRGD1
          ELSE
            IRGD1=IRDA
            IRGD2=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(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
            IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
            PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
            PMQ2=(PMTH(1,IRGD2)**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(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
     &    (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) 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(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
     &    ZL*(1D0-ZU)))
          IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
  480   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 350
      ENDIF
      IRD1=IREF(N+1-NS)
      IRD2=IREF(N+2-NS)
      IF(IGM.GT.0) THEN
        IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
     &  PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) 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 350
        ENDIF
      ENDIF
 
C...Accepted branch. Construct four-momentum for initial partons.
  490 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.GE.3) THEN
C...Rescale all momenta for energy conservation.
        LOOP=0
        PES=0D0
        PQS=0D0
        DO 510 I=1,NEP
          DO 500 J=1,4
            P(N+I,J)=P(IPA(I),J)
  500     CONTINUE
          PES=PES+P(N+I,4)
          PQS=PQS+P(N+I,5)**2/P(N+I,4)
  510   CONTINUE
  520   LOOP=LOOP+1
        FAC=(PS(5)-PQS)/(PES-PQS)
        PES=0D0
        PQS=0D0
        DO 540 I=1,NEP
          DO 530 J=1,3
            P(N+I,J)=FAC*P(N+I,J)
  530     CONTINUE
          P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
          V(N+I,2)=P(N+I,4)
          PES=PES+P(N+I,4)
          PQS=PQS+P(N+I,5)**2/P(N+I,4)
  540   CONTINUE
        IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
 
C...Construct transverse momentum for ordinary branching in shower.
      ELSE
        ZM=V(IM,1)
        LOOPPT=0
  550   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.OR.MSTJ(44).EQ.5)) 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 550
        ELSEIF(PTS.LT.0D0) THEN
          GOTO 280
        ENDIF
        PT=SQRT(MAX(0D0,PTS))
 
C...Global statistics.
        MINT(353)=MINT(353)+1
        VINT(353)=VINT(353)+PT
        IF (MINT(353).EQ.1) VINT(358)=PT
 
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.
  560 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.OR.MSTJ(44).EQ.5)) 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.OR.MSTJ(44).EQ.5)) 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 570 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)
  570   CONTINUE
      ENDIF
 
C...Weight with azimuthal distribution, if required.
      IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
        DO 580 J=1,3
          DPT(1,J)=P(IM,J)
          DPT(2,J)=P(IAU,J)
          DPT(3,J)=P(N+1,J)
  580   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 590 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)
  590   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 560
          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 560
          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 560
        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)-10) 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 290
 
C...Set information on imagined shower initiator.
  600 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 610 I=NS+1+IIM,N
        KQ=KCHG(PYCOMP(K(I,2)),2)
        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(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
          IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
     &    PYR(0).GT.0.5D0) 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(KQ.EQ.1.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
  610 CONTINUE
 
C...Transformation from CM frame.
      IF(NPA.EQ.1) THEN
        THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
        PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
        MSTU(33)=1
        CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
      ELSEIF(NPA.EQ.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))
        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)
        MSTU(33)=1
        CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
      ELSE
        CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
     &  PS(3)/PS(4))
        MSTU(33)=1
        CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
      ENDIF
 
C...Decay vertex of shower.
      DO 630 I=NS+1,N
        DO 620 J=1,5
          V(I,J)=V(IP1,J)
  620   CONTINUE
  630 CONTINUE
 
C...Delete trivial shower, else connect initiators.
      IF(N.LE.NS+NPA+IIM) THEN
        N=NS
      ELSE
        DO 640 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
  640   CONTINUE
      ENDIF
 
      RETURN
      END
 
C*********************************************************************
 
C...PYPTFS
C...Generates pT-ordered timelike final-state parton showers.
 
C...MODE defines how to find radiators and recoilers.
C... = 0 : based on colour flow between undecayed partons.
C... = 1 : for IPART <= NPARTD only consider primary partons,
C...       whether decayed or not; else as above.
C... = 2 : based on common history, whether decayed or not.
C... = 3 : use (or create) MCT color information to shower partons
 
      SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
 
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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      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 /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
     &/PYINT1/
C...Local arrays.
      DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
     &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
     &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
     &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
C...Statement functions.
      SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
     &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
 
C...Initial values. Check that valid system.
      PTGEN=0D0
      IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
     &MSTJ(41).NE.12) RETURN
      IF(NPART.LE.0) THEN
        CALL PYERRM(2,'(PYPTFS:) showering system too small')
        RETURN
      ENDIF
      PT2CMX=PTMAX**2
      IORD=1
 
C...Mass thresholds and Lambda for QCD evolution.
      PMB=PMAS(5,1)
      PMC=PMAS(4,1)
      ALAM5=PARJ(81)
      ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
      ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
      PMBS=PMB**2
      PMCS=PMC**2
      ALAM5S=ALAM5**2
      ALAM4S=ALAM4**2
      ALAM3S=ALAM3**2
 
C...Cutoff scale for QCD evolution. Starting pT2.
      NFLAV=MAX(0,MIN(5,MSTJ(45)))
      PT0C=0.5D0*PARJ(82)
      PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
 
C...Parameters for QED evolution.
      AEM2PI=PARU(101)/PARU(2)
      PT0EQ=0.5D0*PARJ(83)
      PT0EL=0.5D0*PARJ(90)
 
C...Reset. Remove irrelevant colour tags.
      NEVOL=0
      DO 100 J=1,4
        PSUM(J)=0D0
  100 CONTINUE
      DO 110 I=MINT(84)+1,N
        IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
          K(I,5)=0
          MCT(I,2)=0
        ENDIF
        IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
          K(I,4)=0
          MCT(I,1)=0
        ENDIF
  110 CONTINUE
      NPARTS=NPART
 
C...Begin loop to set up showering partons. Sum four-momenta.
      DO 230 IP=1,NPART
        I=IPART(IP)
        IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
          IF(K(I,1).GT.10) GOTO 230
        ELSEIF(K(I,3).GT.MINT(84)) THEN
          IF(K(I,3).GT.MINT(84)+2) GOTO 230
        ELSE
          IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
        ENDIF
        DO 120 J=1,4
          PSUM(J)=PSUM(J)+P(I,J)
  120   CONTINUE
 
C...Find colour and charge, but skip diquarks.
        IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
        KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
        KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
 
C...QUARKONIA++
        IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
          IF (MSTP(148).GE.1) THEN
C...Temporary: force no radiation from quarkonia since not yet treated 
            CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
     &          //' PYPTFS, switched off')
            CALL PYGIVE('MSTP(148)=0')
          ENDIF
          IF (MSTP(148).EQ.0) THEN
C...Skip quarkonia if radiation switched off
            GOTO 230
          ENDIF
        ENDIF
C...QUARKONIA--
 
C...Option to switch off radiation from particle KF = MSTJ(39) entirely
C...(only intended for studying the effects of switching such rad on/off)
        IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
          GOTO 230
        ENDIF
 
C...Either colour or anticolour charge radiates; for gluon both.
        DO 180 JSGCOL=1,-1,-2
          IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
            JCOL=4+(1-JSGCOL)/2
            JCOLR=9-JCOL
 
C...Basic info about radiating parton.
            NEVOL=NEVOL+1
            IPOS(NEVOL)=I
            IFLG(NEVOL)=0
            ISCOL(NEVOL)=JSGCOL
            ISCHG(NEVOL)=0
            PTSCA(NEVOL)=PTPART(IP)
 
C...Begin search for colour recoiler when MODE = 0 or 1.
            IF(MODE.LE.1) THEN
C...Find sister with matching anticolour to the radiating parton.
              IROLD=I
              IRNEW=K(IROLD,JCOL)/MSTU(5)
              MOVE=1
 
C...Skip radiation off loose colour ends.
  130         IF(IRNEW.EQ.0) THEN
                NEVOL=NEVOL-1
                GOTO 180
 
C...Optionally skip radiation on dipole to beam remnant.
              ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
                NEVOL=NEVOL-1
                GOTO 180
 
C...For now always skip radiation on dipole to junction.
              ELSEIF(K(IRNEW,2).EQ.88) THEN
                NEVOL=NEVOL-1
                GOTO 180
 
C...For MODE=1: if reached primary then done.
              ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
     &        IRNEW.LE.NPARTD) THEN
 
C...If sister stable and points back then done.
              ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
     &        THEN
                IF(K(IRNEW,1).LT.10) THEN
 
C...If sister unstable then go to her daughter.
                ELSE
                  IROLD=IRNEW
                  IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
                  MOVE=2
                  GOTO 130
               ENDIF
 
C...If found mother then look for aunt.
              ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
     &        IROLD) THEN
                IROLD=IRNEW
                IRNEW=K(IROLD,JCOL)/MSTU(5)
                GOTO 130
 
C...If daughter stable then done.
              ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
     &        THEN
                IF(K(IRNEW,1).LT.10) THEN
 
C...If daughter unstable then go to granddaughter.
                ELSE
                  IROLD=IRNEW
                  IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
                  MOVE=2
                  GOTO 130
                ENDIF
 
C...If daughter points to another daughter then done or move up.
              ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
     &        IROLD) THEN
                IF(K(IRNEW,1).LT.10) THEN
                ELSE
                  IROLD=IRNEW
                  IRNEW=K(IRNEW,JCOL)/MSTU(5)
                  MOVE=1
                  GOTO 130
                ENDIF
              ENDIF
 
C...Begin search for colour recoiler when MODE = 2.
            ELSEIF (MODE.EQ.2) THEN
              IROLD=I
              IRNEW=K(IROLD,JCOL)/MSTU(5)
  140         IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
C...If no color partner found, pick at random among other primaries
C...(e.g., when the color line is traced all the way to the beam)
                ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
                IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
              ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
C...Step up to mother if radiating parton already branched.
                IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
                  IROLD=IRNEW
                  IRNEW=K(IROLD,JCOL)/MSTU(5)
                  GOTO 140
C...Pick sister by history if no anticolour available.
                ELSE
                  IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
                    IRNEW=IROLD-1
                  ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
     &            THEN
                    IRNEW=IROLD+1
C...Last resort: pick at random among other primaries.
                  ELSE
                    ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
                    IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
                  ENDIF
                ENDIF
              ENDIF
C...Trace down if sister branched.
  150         IF(K(IRNEW,1).GT.10) THEN
                IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
C...If no correct color-daughter found, swap. 
                IF (IRTMP.EQ.0) THEN 
                  JCOL=9-JCOL
                  JCOLR=9-JCOLR
                  IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
                ENDIF
                IRNEW=IRTMP
                GOTO 150
              ENDIF
            ELSEIF (MODE.EQ.3) THEN
C...The following will add MCT colour tracing for unprepped events
C...If not done, trace Les Houches colour tags for this dipole
              JCOLSV=JCOL
              IF (MCT(I,JCOL-3).EQ.0) THEN
C...Special end code -1 : trace to color partner or 0, return in IEND
                IEND=-1
                CALL PYCTTR(I,JCOL,IEND)
C...Clean up mother/daughter 'read' tags set by PYCTTR
                JCOL=JCOLSV
                DO 160 IR=1,N
                  K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
                  K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
                  MCT(IR,1)=0
                  MCT(IR,2)=0
  160           CONTINUE
              ELSE
                IEND=0
                DO 170 IR=1,N
                  IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
     &                IEND=IR
  170           CONTINUE
              ENDIF
C...If no color partner, then we hit beam
              IF (IEND.LE.0) THEN
C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
                IF (MSTP(72).LE.1) THEN
                  NEVOL=NEVOL-1
                  GOTO 180
                ELSE
C...Else try a random partner
                  ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
                  IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
                ENDIF
              ELSE
C...Else save recoiling colour partner
                IRNEW=IEND
              ENDIF
 
            ENDIF
 
C...Now found other end of colour dipole.
            IREC(NEVOL)=IRNEW
          ENDIF
  180   CONTINUE
 
C...Also electrical charge may radiate; so far only quarks and leptons.
        IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
     &  IABS(K(I,2)).LE.18) THEN
 
C...Basic info about radiating parton.
          NEVOL=NEVOL+1
          IPOS(NEVOL)=I
          IFLG(NEVOL)=0
          ISCOL(NEVOL)=0
          ISCHG(NEVOL)=KCHA
          PTSCA(NEVOL)=PTPART(IP)
 
C...Pick nearest (= smallest invariant mass) charged particle
C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
          IF(MODE.LE.1) THEN
            IRNEW=0
            PM2MIN=VINT(2)
            DO 190 IP2=1,NPART+N-MINT(53)
              IF(IP2.EQ.IP) GOTO 190
              IF(IP2.LE.NPART) THEN
                I2=IPART(IP2)
                IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
                  IF(K(I2,1).GT.10) GOTO 190
                ELSEIF(K(I2,3).GT.MINT(84)) THEN
                  IF(K(I2,3).GT.MINT(84)+2) GOTO 190
                ELSE
                  IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
                ENDIF
              ELSE
                I2=MINT(53)+IP2-NPART
              ENDIF
              IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
              PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
     &        (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
              IF(PM2INV.LT.PM2MIN) THEN
                IRNEW=I2
                PM2MIN=PM2INV
              ENDIF
  190       CONTINUE
            IF(IRNEW.EQ.0) THEN
              NEVOL=NEVOL-1
              GOTO 230
            ENDIF
 
C...Begin search for charge recoiler when MODE = 2.
          ELSE
            IROLD=I
C...Pick sister by history; step up if parton already branched.
  200       IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
              IROLD=K(IROLD,3)
              GOTO 200
            ENDIF
            IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
              IRNEW=IROLD-1
            ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
              IRNEW=IROLD+1
C...Last resort: pick at random among other primaries.
            ELSE
              ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
              IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
            ENDIF
C...Trace down if sister branched.
  210       IF(K(IRNEW,1).GT.10) THEN
              DO 220 IR=IRNEW+1,N
                IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
                  IRNEW=IR
                  GOTO 210
                ENDIF
  220         CONTINUE
            ENDIF
          ENDIF
          IREC(NEVOL)=IRNEW
        ENDIF
 
C...End loop to set up showering partons. System invariant mass.
  230 CONTINUE
      IF(NEVOL.LE.0) RETURN
      IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
      PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
 
C...Check if 3-jet matrix elements to be used.
      M3JC=0
      ALPHA=0.5D0
      NMESYS=0
      IF(MSTJ(47).GE.1) THEN
 
C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
        KFSRCE=0
        IPART1=K(IPART(1),3)
        IPART2=K(IPART(2),3)
  240   IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
          KFSRCE=IABS(K(IPART1,2))
        ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
          IPART1=K(IPART1,3)
          GOTO 240
        ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
          IPART2=K(IPART2,3)
          GOTO 240
        ENDIF
        ITYPES=0
        IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
        IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
        IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
        IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
        IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
        IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
        IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
        IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
 
C...Identify two primary showerers.
        KFLA1=IABS(K(IPART(1),2))
        ITYPE1=0
        IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
        IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
        IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
        IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
        IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
        IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
        IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
        IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
        KFLA2=IABS(K(IPART(2),2))
        ITYPE2=0
        IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
        IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
        IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
        IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
        IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
        IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
        IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
        IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
 
C...Order of showerers. Presence of gluino.
        ITYPMN=MIN(ITYPE1,ITYPE2)
        ITYPMX=MAX(ITYPE1,ITYPE2)
        IORD=1
        IF(ITYPE1.GT.ITYPE2) IORD=2
        IGLUI=0
        IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
 
C...Require exactly two primary showerers for ME corrections.
        NPRIM=0
        IF(IPART1.GT.0) THEN
          DO 250 I=1,N
            IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
  250     CONTINUE
        ENDIF
        IF(NPRIM.NE.2) THEN
 
C...Predetermined and default matrix element kinds.
        ELSEIF(MSTJ(38).NE.0) THEN
          M3JC=MSTJ(38)
          ALPHA=PARJ(80)
          MSTJ(38)=0
        ELSEIF(MSTJ(47).GE.6) THEN
          M3JC=MSTJ(47)
        ELSE
          ICLASS=1
          ICOMBI=4
 
C...Vector/axial vector -> q + qbar; q -> q + V.
          IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.3)) THEN
            ICLASS=2
            IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
              ICOMBI=1
            ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
     &      K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
C...gamma*/Z0: assume e+e- initial state if unknown.
              EI=-1D0
              IF(KFSRCE.EQ.23) THEN
                IANNFL=IPART1
                IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
                IF(IANNFL.GT.0) THEN
                  IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
                ENDIF
                IF(IANNFL.NE.0) THEN
                  KANNFL=IABS(K(IANNFL,2))
                  IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
                ENDIF
              ENDIF
              AI=SIGN(1D0,EI+0.1D0)
              VI=AI-4D0*EI*PARU(102)
              EF=KCHG(KFLA1,1)/3D0
              AF=SIGN(1D0,EF+0.1D0)
              VF=AF-4D0*EF*PARU(102)
              XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
              SH=PSUM(5)**2
              SQMZ=PMAS(23,1)**2
              SQWZ=PSUM(5)*PMAS(23,2)
              SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
              VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
     &        (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
              AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
              ICOMBI=3
              ALPHA=VECT/(VECT+AXIV)
            ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
              ICOMBI=4
            ENDIF
C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
            ICLASS=2
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=3
 
C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
            ICLASS=4
            IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
              ICOMBI=1
            ELSEIF(KFSRCE.EQ.36) THEN
              ICOMBI=2
            ENDIF
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=5
 
C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.3)) THEN
            ICLASS=6
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=7
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
            ICLASS=8
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=9
 
C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.5)) THEN
            ICLASS=10
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=11
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=12
 
C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
            ICLASS=13
          ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.2)) THEN
            ICLASS=14
          ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
     &    ITYPES.EQ.1)) THEN
            ICLASS=15
 
C...g -> ~g + ~g (eikonal approximation).
          ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
            ICLASS=16
          ENDIF
          M3JC=5*ICLASS+ICOMBI
        ENDIF
 
C...Store pair that together define matrix element treatment.
        IF(M3JC.NE.0) THEN
          NMESYS=1
          MESYS(NMESYS,0)=M3JC
          MESYS(NMESYS,1)=IPART(1)
          MESYS(NMESYS,2)=IPART(2)
        ENDIF
 
C...Store qqbar or l+l- pairs for QED radiation.
        IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
          NMESYS=NMESYS+1
          MESYS(NMESYS,0)=101
          IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
          MESYS(NMESYS,1)=IPART(1)
          MESYS(NMESYS,2)=IPART(2)
        ENDIF
 
C...Store other qqbar/l+l- pairs from g/gamma branchings.
        DO 290 I1=1,N
          IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
          I1M=K(I1,3)
  260     IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
            I1M=K(I1M,3)
            GOTO 260
          ENDIF
C...Move up this check to avoid out-of-bounds.
          IF(I1M.EQ.0) GOTO 290
          IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
          DO 280 I2=I1+1,N
            IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
            I2M=K(I2,3)
  270       IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
              I2M=K(I2M,3)
              GOTO 270
            ENDIF
            IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
              NMESYS=NMESYS+1
              MESYS(NMESYS,0)=66
              MESYS(NMESYS,1)=I1
              MESYS(NMESYS,2)=I2
              NMESYS=NMESYS+1
              MESYS(NMESYS,0)=102
              MESYS(NMESYS,1)=I1
              MESYS(NMESYS,2)=I2
            ENDIF
  280     CONTINUE
  290   CONTINUE
      ENDIF
 
C..Loopback point for counting number of emissions.
      NGEN=0
  300 NGEN=NGEN+1
 
C...Begin loop to evolve all existing partons, if required.
  310 IMX=0
      PT2MX=0D0
      DO 380 IEVOL=1,NEVOL
        IF(IFLG(IEVOL).EQ.0) THEN
 
C...Basic info on radiator and recoil.
          I=IPOS(IEVOL)
          IR=IREC(IEVOL)
          SHT=SHAT(I,IR)
          PM2I=P(I,5)**2
          PM2R=P(IR,5)**2
 
C...Invariant mass of "dipole".Starting value for pT evolution.
          SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
          PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
 
C...Case of evolution by QCD branching.
          IF(ISCOL(IEVOL).NE.0) THEN
 
C...Parton-by-parton maximum scale from initial conditions.
          IF(MSTP(72).EQ.0) THEN
            DO 320 IPRT=1,NPARTS
              IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
  320       CONTINUE
          ENDIF
 
C...If kinematically impossible then do not evolve.
            IF(PT2.LT.PT2CMN) THEN
              IFLG(IEVOL)=-1
              GOTO 380
            ENDIF
 
C...Check if part of system for which ME corrections should be applied.
            IMESYS=0
            DO 330 IME=1,NMESYS
              IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
     &        MESYS(IME,0).LT.100) IMESYS=IME
  330       CONTINUE
 
C...Special flag for colour octet states.
C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
            MOCT=0
            IF(K(I,2).EQ.21) MOCT=1
C...SUSY gluino
            IF(K(I,2).EQ.KSUSY1+21) MOCT=2
C...UED KK gluon
            IF(K(I,2).EQ.5100021) MOCT=2
C...QUARKONIA++
            IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
     &          IABS(K(I,2)).LE.9910555) MOCT=2
C...QUARKONIA--
 
 
C...Upper estimate for matrix element weighting and colour factor.
C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
            WTPSGL=2D0
            COLFAC=4D0/3D0
            IF(MOCT.GE.1) COLFAC=3D0/2D0
            IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
            WTPSQQ=0.5D0*0.5D0*NFLAV
 
C...Determine overestimated z range: switch at c and b masses.
  340       IZRG=1
            PT2MNE=PT2CMN
            B0=27D0/6D0
            ALAMS=ALAM3S
            IF(PT2.GT.1.01D0*PMCS) THEN
              IZRG=2
              PT2MNE=PMCS
              B0=25D0/6D0
              ALAMS=ALAM4S
            ENDIF
            IF(PT2.GT.1.01D0*PMBS) THEN
              IZRG=3
              PT2MNE=PMBS
              B0=23D0/6D0
              ALAMS=ALAM5S
            ENDIF
            ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
            IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
 
C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
            EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
            EVCOEF=EVEMGL
            IF(MOCT.EQ.1) THEN
              EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
              EVCOEF=EVCOEF+EVEMQQ
            ENDIF
 
C...Pick pT2 (in overestimated z range).
  350       PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
 
C...Loopback if crossed c/b mass thresholds.
            IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
              PT2=PMBS
              GOTO 340
            ENDIF
            IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
              PT2=PMCS
              GOTO 340
            ENDIF
 
C...Finish if below lower cutoff.
            IF(PT2.LT.PT2CMN) THEN
              IFLG(IEVOL)=-1
              GOTO 380
            ENDIF
 
C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
            IFLAG=1
            IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
 
C...Pick z: dz/(1-z) or dz.
            IF(IFLAG.EQ.1) THEN
              Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
            ELSE
              Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
            ENDIF
 
C...Loopback if outside allowed range for given pT2.
            ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
            IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
            IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
            PM2=PM2I+PT2/(Z*(1D0-Z))
            IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
 
C...No weighting for primary partons; to be done later on.
            IF(IMESYS.GT.0) THEN
 
C...Weighting of q->qg/X->Xg branching.
            ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
              IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
 
C...Weighting of g->gg branching.
            ELSEIF(IFLAG.EQ.1) THEN
              IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
 
C...Flavour choice and weighting of g->qqbar branching.
            ELSE
              KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
              PMQ=PMAS(KFQ,1)
              ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
              WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
              IF(WTME.LT.PYR(0)) GOTO 350
              IFLAG=10+KFQ
            ENDIF
 
C...Case of evolution by QED branching.
          ELSEIF(ISCHG(IEVOL).NE.0) THEN
 
C...If kinematically impossible then do not evolve.
            PT2EMN=PT0EQ**2
            IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
            IF(PT2.LT.PT2EMN) THEN
              IFLG(IEVOL)=-1
              GOTO 380
            ENDIF
 
C...Check if part of system for which ME corrections should be applied.
           IMESYS=0
            DO 360 IME=1,NMESYS
              IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
     &        MESYS(IME,0).GT.100) IMESYS=IME
  360      CONTINUE
 
C...Charge. Matrix element weighting factor.
            CHG=ISCHG(IEVOL)/3D0
            WTPSGA=2D0
 
C...Determine overestimated z range. Find evolution coefficient.
            ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
            IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
            EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
 
C...Pick pT2 (in overestimated z range).
  370       PT2=PT2*PYR(0)**(1D0/EVCOEF)
 
C...Finish if below lower cutoff.
            IF(PT2.LT.PT2EMN) THEN
              IFLG(IEVOL)=-1
              GOTO 380
            ENDIF
 
C...Pick z: dz/(1-z).
            Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
 
C...Loopback if outside allowed range for given pT2.
            ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
            IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
            IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
            PM2=PM2I+PT2/(Z*(1D0-Z))
            IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
 
C...Weighting by branching kernel, except if ME weighting later.
            IF(IMESYS.EQ.0) THEN
              IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
            ENDIF
            IFLAG=3
          ENDIF
 
C...Save acceptable branching.
          IFLG(IEVOL)=IFLAG
          IMESAV(IEVOL)=IMESYS
          PT2SAV(IEVOL)=PT2
          ZSAV(IEVOL)=Z
          SHTSAV(IEVOL)=SHT
        ENDIF
 
C...Check if branching has highest pT.
        IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
          IMX=IEVOL
          PT2MX=PT2SAV(IEVOL)
        ENDIF
  380 CONTINUE
 
C...Finished if no more branchings to be done.
      IF(IMX.EQ.0) GOTO 500
 
C...Restore info on hardest branching to be processed.
      I=IPOS(IMX)
      IR=IREC(IMX)
      KCOL=ISCOL(IMX)
      KCHA=ISCHG(IMX)
      IMESYS=IMESAV(IMX)
      PT2=PT2SAV(IMX)
      Z=ZSAV(IMX)
      SHT=SHTSAV(IMX)
      PM2I=P(I,5)**2
      PM2R=P(IR,5)**2
      PM2=PM2I+PT2/(Z*(1D0-Z))
 
C...Special flag for colour octet states.
      MOCT=0
      IF(K(I,2).EQ.21) MOCT=1
      IF(K(I,2).EQ.KSUSY1+21) MOCT=2
      IF(K(I,2).EQ.5100021) MOCT=2
C...QUARKONIA++
      IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
     &    IABS(K(I,2)).LE.9910555) MOCT=2
C...QUARKONIA--
 
C...Restore further info for g->qqbar branching.
      KFQ=0
      IF(IFLG(IMX).GT.10) THEN
        KFQ=IFLG(IMX)-10
        PMQ=PMAS(KFQ,1)
        ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
      ENDIF
 
C...For branching g include azimuthal asymmetries from polarization.
      ASYPOL=0D0
      IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
C...Trace grandmother via intermediate recoil copies.
        KFGM=0
        IM=I
  390   IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
     &  K(IM,3).GT.0) THEN
          IM=K(IM,3)
          IF(IM.GT.MINT(84)) GOTO 390
        ENDIF
        IGM=K(IM,3)
        IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
     &  KFGM=IABS(K(IGM,2))
C...Define approximate energy sharing by identifying aunt.
        IAU=IM+1
        IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
        IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
          ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
C...Coefficient from gluon production.
          IF(KFGM.LE.6) THEN
            ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
          ELSE
            ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
          ENDIF
C...Coefficient from gluon decay.
          IF(KFQ.EQ.0) THEN
            ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
          ELSE
            ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
          ENDIF
        ENDIF
      ENDIF
 
C...Create new slots for branching products and recoil.
      INEW=N+1
      IGNEW=N+2
      IRNEW=N+3
      N=N+3
 
C...Set status, flavour and mother of new ones.
      K(INEW,1)=K(I,1)
      K(IGNEW,1)=3
      IF(KCHA.NE.0)  K(IGNEW,1)=1
      K(IRNEW,1)=K(IR,1)
      IF(KFQ.EQ.0) THEN
        K(INEW,2)=K(I,2)
        K(IGNEW,2)=21
        IF(KCHA.NE.0)  K(IGNEW,2)=22
      ELSE
        K(INEW,2)=-ISIGN(KFQ,KCOL)
        K(IGNEW,2)=-K(INEW,2)
      ENDIF
      K(IRNEW,2)=K(IR,2)
      K(INEW,3)=I
      K(IGNEW,3)=I
      K(IRNEW,3)=IR
 
C...Find rest frame and angles of branching+recoil.
      DO 400 J=1,5
        P(INEW,J)=P(I,J)
        P(IGNEW,J)=0D0
        P(IRNEW,J)=P(IR,J)
  400 CONTINUE
      BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
      BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
      BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
      CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
      PHI=PYANGL(P(INEW,1),P(INEW,2))
      THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
 
C...Derive kinematics of branching: generics (like g->gg).
      DO 410 J=1,4
        P(INEW,J)=0D0
        P(IRNEW,J)=0D0
  410 CONTINUE
      PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
      PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
      PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
      PTCOR=SQRT(MAX(0D0,PT2COR))
      PZN=(PEM**2*Z-0.5D0*PM2)/PZM
      PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
C...Specific kinematics reduction for q->qg with m_q > 0.
      IF(MOCT.NE.1) THEN
        PTCOR=(1D0-PM2I/PM2)*PTCOR
        PZN=PZN+PM2I*PZG/PM2
        PZG=(1D0-PM2I/PM2)*PZG
C...Specific kinematics reduction for g->qqbar with m_q > 0.
      ELSEIF(KFQ.NE.0) THEN
        P(INEW,5)=PMQ
        P(IGNEW,5)=PMQ
        PTCOR=ROOTQQ*PTCOR
        PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
        PZG=PZM-PZN
      ENDIF
 
C...Pick phi and construct kinematics of branching.
  420 PHIROT=PARU(2)*PYR(0)
      P(INEW,1)=PTCOR*COS(PHIROT)
      P(INEW,2)=PTCOR*SIN(PHIROT)
      P(INEW,3)=PZN
      P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
      P(IGNEW,1)=-P(INEW,1)
      P(IGNEW,2)=-P(INEW,2)
      P(IGNEW,3)=PZG
      P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
      P(IRNEW,1)=0D0
      P(IRNEW,2)=0D0
      P(IRNEW,3)=-PZM
      P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
 
C...Boost branching system to lab frame.
      CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
 
C...Renew choice of phi angle according to polarization asymmetry.
      IF(ABS(ASYPOL).GT.1D-3) THEN
        DO 430 J=1,3
          DPT(1,J)=P(I,J)
          DPT(2,J)=P(IAU,J)
          DPT(3,J)=P(INEW,J)
  430   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 440 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)
  440   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(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
     &    GOTO 420
        ENDIF
      ENDIF
 
C...Matrix element corrections for primary partons when requested.
      IF(IMESYS.GT.0) THEN
        M3JC=MESYS(IMESYS,0)
 
C...Identify recoiling partner and set up three-body kinematics.
        IRP=MESYS(IMESYS,1)
        IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
        IF(IRP.EQ.IR) IRP=IRNEW
        DO 450 J=1,4
          PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
  450   CONTINUE
        PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
     &  PSUM(3)**2))
        X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
     &  PSUM(3)*P(INEW,3))/PSUM(5)**2
        X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
     &  PSUM(3)*P(IRP,3))/PSUM(5)**2
        X3=2D0-X1-X2
        R1ME=P(INEW,5)/PSUM(5)
        R2ME=P(IRP,5)/PSUM(5)
 
C...Matrix elements for gluon emission.
        IF(M3JC.LT.100) THEN
 
C...Call ME, with right order important for two inequivalent showerers.
          IF(MESYS(IMESYS,IORD).EQ.I) THEN
            WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
          ELSE
            WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
          ENDIF
 
C...Split up total ME when two radiating partons.
          ISPRAD=1
          IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
     &    .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
     &    .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
          IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
     &    MAX(1D-10,2D0-X1-X2)
 
C...Evaluate shower rate.
          WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
     &    MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
          IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
 
C...Matrix elements for photon emission: still rather primitive.
        ELSE
 
C...For generic charge combination currently only massless expression.
          IF(M3JC.EQ.101) THEN
            CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
            CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
            WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
            WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
 
C...For flavour neutral system assume vector source and include masses.
          ELSE
            WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
     &      1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
            WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
     &      MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
          ENDIF
        ENDIF
 
C...Perform weighting with W_ME/W_PS.
        IF(WME.LT.PYR(0)*WPS) THEN
          N=N-3
          IFLG(IMX)=0
          PT2CMX=PT2
          GOTO 310
        ENDIF
      ENDIF
 
C...Now for sure accepted branching. Save highest pT.
      IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
 
C...Update status for obsolete ones. Bookkkep the moved original parton
C...and new daughter (arbitrary choice for g->gg or g->qqbar).
C...Do not bookkeep radiated photon, since it cannot radiate further.
      K(I,1)=K(I,1)+10
      K(IR,1)=K(IR,1)+10
      DO 460 IP=1,NPART
        IF(IPART(IP).EQ.I) IPART(IP)=INEW
        IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
  460 CONTINUE
      IF(KCHA.EQ.0) THEN
        NPART=NPART+1
        IPART(NPART)=IGNEW
      ENDIF
 
C...Initialize colour flow of branching.
C...Use both old and new style colour tags for flexibility.
      K(INEW,4)=0
      K(IGNEW,4)=0
      K(INEW,5)=0
      K(IGNEW,5)=0
      JCOLP=4+(1-KCOL)/2
      JCOLN=9-JCOLP
      MCT(INEW,1)=0
      MCT(INEW,2)=0
      MCT(IGNEW,1)=0
      MCT(IGNEW,2)=0
      MCT(IRNEW,1)=0
      MCT(IRNEW,2)=0
 
C...Trivial colour flow for l->lgamma and q->qgamma.
      IF(IABS(KCHA).EQ.3) THEN
        K(I,4)=INEW
        K(I,5)=IGNEW
      ELSEIF(KCHA.NE.0) THEN
        IF(K(I,4).NE.0) THEN
          K(I,4)=K(I,4)+INEW
          K(INEW,4)=MSTU(5)*I
          MCT(INEW,1)=MCT(I,1)
        ENDIF
        IF(K(I,5).NE.0) THEN
          K(I,5)=K(I,5)+INEW
          K(INEW,5)=MSTU(5)*I
          MCT(INEW,2)=MCT(I,2)
        ENDIF
 
C...Set colour flow for q->qg and g->gg.
      ELSEIF(KFQ.EQ.0) THEN
        K(I,JCOLP)=K(I,JCOLP)+IGNEW
        K(IGNEW,JCOLP)=MSTU(5)*I
        K(INEW,JCOLP)=MSTU(5)*IGNEW
        K(IGNEW,JCOLN)=MSTU(5)*INEW
        MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
        NCT=NCT+1
        MCT(INEW,JCOLP-3)=NCT
        MCT(IGNEW,JCOLN-3)=NCT
        IF(MOCT.GE.1) THEN
          K(I,JCOLN)=K(I,JCOLN)+INEW
          K(INEW,JCOLN)=MSTU(5)*I
          MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
        ENDIF
 
C...Set colour flow for g->qqbar.
      ELSE
        K(I,JCOLN)=K(I,JCOLN)+INEW
        K(INEW,JCOLN)=MSTU(5)*I
        K(I,JCOLP)=K(I,JCOLP)+IGNEW
        K(IGNEW,JCOLP)=MSTU(5)*I
        MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
        MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
      ENDIF
 
C...Daughter info for colourless recoiling parton.
      IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
        K(IR,4)=IRNEW
        K(IR,5)=IRNEW
        K(IRNEW,4)=0
        K(IRNEW,5)=0
 
C...Colour of recoiling parton sails through unchanged.
      ELSE
        IF(K(IR,4).NE.0) THEN
          K(IR,4)=K(IR,4)+IRNEW
          K(IRNEW,4)=MSTU(5)*IR
          MCT(IRNEW,1)=MCT(IR,1)
        ENDIF
        IF(K(IR,5).NE.0) THEN
          K(IR,5)=K(IR,5)+IRNEW
          K(IRNEW,5)=MSTU(5)*IR
          MCT(IRNEW,2)=MCT(IR,2)
        ENDIF
      ENDIF
 
C...Vertex information trivial.
      DO 470 J=1,5
        V(INEW,J)=V(I,J)
        V(IGNEW,J)=V(I,J)
        V(IRNEW,J)=V(IR,J)
  470 CONTINUE
 
C...Update list of old radiators.
        DO 480 IEVOL=1,NEVOL
          IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
            IPOS(IEVOL)=INEW
            IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
            IREC(IEVOL)=IRNEW
            IFLG(IEVOL)=0
          ELSEIF(IPOS(IEVOL).EQ.I) THEN
            IPOS(IEVOL)=INEW
            IFLG(IEVOL)=0
          ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
            IPOS(IEVOL)=IRNEW
            IREC(IEVOL)=INEW
            IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
            IFLG(IEVOL)=0
          ELSEIF(IPOS(IEVOL).EQ.IR) THEN
            IPOS(IEVOL)=IRNEW
            IFLG(IEVOL)=0
          ENDIF
C...Update links of old connected partons.
          IF(IREC(IEVOL).EQ.I) THEN
            IREC(IEVOL)=INEW
            IFLG(IEVOL)=0
          ELSEIF(IREC(IEVOL).EQ.IR) THEN
            IREC(IEVOL)=IRNEW
            IFLG(IEVOL)=0
          ENDIF
  480   CONTINUE
 
C...q->qg or g->gg: create new gluon radiators.
      IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
        NEVOL=NEVOL+1
        IPOS(NEVOL)=INEW
        IREC(NEVOL)=IGNEW
        IFLG(NEVOL)=0
        ISCOL(NEVOL)=KCOL
        ISCHG(NEVOL)=0
        PTSCA(NEVOL)=SQRT(PT2)
        NEVOL=NEVOL+1
        IPOS(NEVOL)=IGNEW
        IREC(NEVOL)=INEW
        IFLG(NEVOL)=0
        ISCOL(NEVOL)=-KCOL
        ISCHG(NEVOL)=0
        PTSCA(NEVOL)=PTSCA(NEVOL-1)
      ENDIF
 
C...Update matrix elements parton list and add new for g/gamma->qqbar.
      DO 490 IME=1,NMESYS
        IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
        IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
        IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
        IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
  490 CONTINUE
      IF(KFQ.NE.0) THEN
        NMESYS=NMESYS+1
        MESYS(NMESYS,0)=66
        MESYS(NMESYS,1)=INEW
        MESYS(NMESYS,2)=IGNEW
        NMESYS=NMESYS+1
        MESYS(NMESYS,0)=102
        MESYS(NMESYS,1)=INEW
        MESYS(NMESYS,2)=IGNEW
      ENDIF
 
C...Global statistics.
      MINT(353)=MINT(353)+1
      VINT(353)=VINT(353)+PTCOR
      IF (MINT(353).EQ.1) VINT(358)=PTCOR
 
C...Loopback for more emissions if enough space.
      PT2CMX=PT2
      IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
     &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
        GOTO 300
      ELSE
        CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
      ENDIF
 
C...Done.
  500 CONTINUE
 
      RETURN
      END
 
C*********************************************************************
 
C...PYMAEL
C...Auxiliary to PYSHOW and PYPTFS.
C...Matrix elements for gluon (or photon) emission from
C...a two-body state; to be used by the parton shower routine.
C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
C...      = (alpha-strong/2 pi) * CF * PYMAEL,
C...i.e. normalization is such that one recovers the familiar
C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
C...Coupling structure:
C...NI =  6- 9 : eikonal soft-gluon expression (spin-independent)
C...   = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
C...   = 16-19 : q -> q V
C...   = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
C...   = 26-29 : q -> q S
C...   = 31-34 : V -> ~q ~qbar  (~q = squark)
C...   = 36-39 : ~q -> ~q V
C...   = 41-44 : S -> ~q ~qbar
C...   = 46-49 : ~q -> ~q S
C...   = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
C...   = 56-59 : ~q -> q chi
C...   = 61-64 : q -> ~q chi
C...   = 66-69 : ~g -> q ~qbar
C...   = 71-74 : ~q -> q ~g
C...   = 76-79 : q -> ~q ~g
C...   = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
C...Note that the order of the decay products is important.
C...In each set of four, the variants are ordered as:
C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
C...       = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
C...       = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
C...       = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
 
      FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...Check input values. Return zero outside allowed phase space.
      PYMAEL=0D0
      IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
      IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
      IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
      IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
     &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
      ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
 
C...Initial values and flags.
      ICLASS=NI/5
      ICOMBI=NI-5*ICLASS
      ISSET1=0
      ISSET2=0
      ISSET4=0
 
C... Phase space.
      PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
 
C...Eikonal expression; also acts as default.
      IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
        RLO=PS
        IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
          ANUM=0D0
        ELSEIF(ICOMBI.EQ.2) THEN
          ANUM=(2D0-X1-X2)**2
        ELSEIF(ICOMBI.EQ.3) THEN
          ANUM=ALPCOR*(2D0-X1-X2)**2
        ELSE
          ANUM=0.5D0*(2D0-X1-X2)**2
        ENDIF
        RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
     &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
     &       R1**2/(1D0+R2**2-R1**2-X2)**2-
     &       R2**2/(1D0+R1**2-R2**2-X1)**2)
        ICOMBI=0
 
C...V -> q qbar (V = gamma*/Z0/W+-/...).
      ELSEIF(ICLASS.EQ.2) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
        RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
     &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
     &       +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
     &       +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
     &       -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
     &       -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
     &       +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
     &       (-1+R1**2-R2**2+X2)**2
        RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
     &       +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
     &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
     &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
     &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
     &       -X1-X2)**2+X1*(2-X1-X2)**2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
        RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
     &       -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
     &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
     &       -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
     &       (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
        RFO1=RFO1/2.D0
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
        RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
     &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
     &       +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
     &       -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
     &       +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
     &       -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
     &       +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
        RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
     &       -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
     &       -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
     &       -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
     &       +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
     &       -X1-X2)**2+X1*(2-X1-X2)**2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
        RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
     &       -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
     &       +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
     &       -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
     &       +X2)/(-1-R1**2+R2**2+X1)**2
        RFO2=RFO2/2.D0
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
        RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
     &       -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
     &       +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
     &       (-1-R1**2+R2**2+X1)**2
        RFO4=RFO4
     &       -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
     &       -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
     &       -R1**2*X2**2+X1*X2**2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
        RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
     &       -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
     &       +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
     &       (-1+R1**2-R2**2+X2)**2
        RFO4=RFO4/2.D0
        ISSET4=1
        ENDIF
 
C...q -> q V.
      ELSEIF(ICLASS.EQ.3) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
     &        +R1**2*R2**2-2D0*R2**4)
        RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
     &       -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
     &       +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
     &       +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
     &       +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
     &       -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
     &       -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
        RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
     &       +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
     &       -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
     &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
     &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
        RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
     &       +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
     &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
     &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
     &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
     &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
     &       +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
     &        +R1**2*R2**2-2D0*R2**4)
        RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
     &       +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
     &       -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
     &       -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
     &       -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
     &       +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
     &       -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
        RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
     &       +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
     &       -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
     &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
     &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
        RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
     &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
     &       +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
     &       +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
     &       +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
     &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
     &       +X1*X2**2)/(-2+X1+X2)**2
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
        RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
     &       -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
     &       -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
     &       +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
     &       +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
        RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
     &       -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
     &       -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
     &       +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
        RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
     &       +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
     &       -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
     &       -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
     &       +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
     &       +X1*X2**2)/(2-X1-X2)**2
        ISSET4=1
        ENDIF
 
C...S -> q qbar    (S = h0/H0/A0/H+-/...).
      ELSEIF(ICLASS.EQ.4) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
        RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
     &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
     &       -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
     &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
     &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
     &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
        RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
     &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
     &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
     &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
     &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
     &       +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
     &       -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
     &       -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0-R1**2-R2**2)
        RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
     &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
     &       -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
     &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
     &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
     &       +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
        ISSET4=1
        ENDIF
 
C...q -> q S.
      ELSEIF(ICLASS.EQ.5) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
        RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
     &       -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
     &       +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
     &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
     &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
     &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (-1+R1**2-R2**2+X2)**2
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
        RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
     &       +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
     &       +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
     &       +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (1-R1**2+R2**2-X2)/(-2+X1+X2)
     &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
     &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (-1+R1**2-R2**2+X2)**2
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0+R1**2-R2**2)
        RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
     &       -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
     &       +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
     &       -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
     &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
     &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
        ISSET4=1
        ENDIF
 
C...V -> ~q ~qbar  (~q = squark).
      ELSEIF(ICLASS.EQ.6) THEN
        RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
        RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
     &       (-1-R1**2+R2**2+X1)**2
     &       -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
     &       (-1-R1**2+R2**2+X1)
     &       +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
     &       /(-1+R1**2-R2**2+X2)**2
     &       -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
     &       (-1+R1**2-R2**2+X2)
     &       -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
     &       +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
     &       -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
     &       +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
        ISSET1=1
 
C...~q -> ~q V.
      ELSEIF(ICLASS.EQ.7) THEN
        RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
        RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
     &       -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
     &       (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
     &       (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
     &       +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
     &       -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
     &       (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
     &       (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
     &       +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
     &       +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
     &       (3*(-2+X1+X2))
        RFO1=3D0*RFO1/8D0
        ISSET1=1
 
C...S -> ~q ~qbar.
      ELSEIF(ICLASS.EQ.8) THEN
        RLO1=PS
        RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
     &       +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
     &       +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
     &       -R1**2*X2**2+X1*X2**2)/
     &       (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
        RFO1=2D0*RFO1
        ISSET1=1
 
C...~q -> ~q S.
      ELSEIF(ICLASS.EQ.9) THEN
        RLO1=PS
        RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
     &       +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
     &       -(X1+X2)/(-2+X1+X2)**2
        ISSET1=1
 
C...chi -> q ~qbar   (chi = neutralino/chargino).
      ELSEIF(ICLASS.EQ.10) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
        RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
     &       +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
     &       -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
     &       +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
     &       -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (-1+R1**2-R2**2+X2)**2
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
        RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
     &       +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
     &       -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
     &       +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
     &       -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (-1+R1**2-R2**2+X2)**2
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1+R1**2-R2**2)
        RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
     &       +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
     &       +X2+R1**2*X2-X1*X2/2)/
     &       (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
     &       +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
     &       -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
        ISSET4=1
        ENDIF
 
C...~q -> q chi.
      ELSEIF(ICLASS.EQ.11) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0-(R1+R2)**2)
        RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
     &       -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
     &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
     &       +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
     &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
     &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-(R1-R2)**2)
        RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
     &       (-2+X1+X2)**2
     &       -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
     &       -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
     &       +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
     &       +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
     &       +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0-R1**2-R2**2)
        RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
     &       -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
     &       +3*R1**2*X2-R2**2*X2-X1*X2)/
     &       (-1+R1**2-R2**2+X2)**2
     &       -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
     &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
     &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
        ISSET4=1
        ENDIF
 
C...q -> ~q chi.
      ELSEIF(ICLASS.EQ.12) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
        RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
     &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
     &       -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
     &       (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
     &       +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
     &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
        ISSET1=1
        END IF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
        RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
     &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
     &       -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
     &       (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
     &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
     &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
        ISSET2=1
        END IF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0-R1**2+R2**2)
        RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
     &       +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
     &       -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
     &       (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
     &       +R1**2*X2-X1*X2/2-X2**2/2)/
     &       (2-X1-X2)/(-1+R1**2-R2**2+X2)
        ISSET4=1
        END IF
 
C...~g -> q ~qbar.
      ELSEIF(ICLASS.EQ.13) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
        RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
     &       -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
     &       -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
     &       +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
     &       +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
     &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
     &       -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
     &       +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
     &       +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
     &       +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
     &       -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
     &       -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (3*(-1+R1**2-R2**2+X2)**2)
        RFO1=3D0*RFO1/4D0
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
        RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
     &       -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
     &       +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
     &       +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
     &       +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
     &       (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
     &       +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
     &       +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
     &       -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
     &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
     &       +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
     &       +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (3*(-1+R1**2-R2**2+X2)**2)
        RFO2=3D0*RFO2/4D0
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0+R1**2-R2**2)
        RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
     &       -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
     &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
     &       +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
     &       +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
     &       +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
     &       +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
     &       +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
     &       (3*(-1+R1**2-R2**2+X2)**2)
        RFO4=3D0*RFO4/8D0
        ISSET4=1
        ENDIF
 
C...~q -> q ~g.
      ELSEIF(ICLASS.EQ.14) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
        RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
     &       -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
     &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
     &       -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
     &       -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
     &       -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
     &       -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
     &       +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
     &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
     &       +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
     &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
     &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
        RFO1=RFO1
     &       +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
     &       +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
     &       +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
        RFO1=9D0*RFO1/64D0
        ISSET1=1
        ENDIF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
        RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
     &       -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
     &       +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
     &       -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
     &       +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
     &       -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
     &       -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
     &       -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
     &       +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
     &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
        RFO2=RFO2
     &       +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
     &       -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
     &       +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
     &       +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
     &       +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
     &       -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
        RFO2=9D0*RFO2/64D0
        ISSET2=1
        ENDIF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1-R1**2-R2**2)
        RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
     &       +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
     &       +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
     &       -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
     &       +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
     &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
     &       -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
     &       -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
     &       +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
     &       +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
     &       ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
        RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
     &       +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
     &       (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
        RFO4=9D0*RFO4/128D0
        ISSET4=1
        ENDIF
 
C...q -> ~q ~g.
      ELSEIF(ICLASS.EQ.15) THEN
        IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
        RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
        RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
     &       +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
     &       +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
     &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
     &       -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
     &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
     &       (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
     &       -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
     &       +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
        RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
     &       +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
     &       ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
     &       -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
     &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
        RFO1=9D0*RFO1/32D0
        ISSET1=1
        END IF
        IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
        RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
        RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
     &       +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
     &       +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
     &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
     &       +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
     &       +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
     &       (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
     &       +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
     &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
        RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
     &       +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
     &       (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
     &       -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
     &       (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
        RFO2=9D0*RFO2/32D0
        ISSET2=1
        END IF
        IF(ICOMBI.EQ.4) THEN
        RLO4=PS*(1D0-R1**2+R2**2)
        RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
     &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
     &       -R2**2*X2/2-X1*X2/2)/
     &       ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
     &       -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
     &       +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
     &       +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
     &       -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
        RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
     &       -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
     &       +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
     &       -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
        RFO4=9D0*RFO4/64D0
        ISSET4=1
        END IF
 
C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
      ELSEIF(ICLASS.EQ.16) THEN
        RLO=PS
        IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
          ANUM=0D0
        ELSEIF(ICOMBI.EQ.2) THEN
          ANUM=(2D0-X1-X2)**2
        ELSEIF(ICOMBI.EQ.3) THEN
          ANUM=ALPCOR*(2D0-X1-X2)**2
        ELSE
          ANUM=0.5D0*(2D0-X1-X2)**2
        ENDIF
        RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
     &       ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
     &       R1**2/(1D0+R2**2-R1**2-X2)**2-
     &       R2**2/(1D0+R1**2-R2**2-X1)**2)
        RFO=9D0*RFO/4D0
        ICOMBI=0
      ENDIF
 
C...Find relevant LO and FO expression.
      IF(ICOMBI.EQ.0) THEN
      ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
        RLO=RLO1
        RFO=RFO1
      ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
        RLO=RLO2
        RFO=RFO2
      ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
        RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
        RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
      ELSEIF(ISSET4.EQ.1) THEN
        RLO=RLO4
        RFO=RFO4
      ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
        RLO=0.5D0*(RLO1+RLO2)
        RFO=0.5D0*(RFO1+RFO2)
      ELSEIF(ISSET1.EQ.1) THEN
        RLO=RLO1
        RFO=RFO1
      ELSE
        CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
        RLO=1D0
        RFO=0D0
      ENDIF
 
C...Output.
      PYMAEL=RFO/RLO
 
      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
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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/PYINT1/MINT(400),VINT(400)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
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...Check if we have separated strings
 
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 190 IBE=1,MIN(10,MSTJ(52)+1)
        NBE(IBE)=NBE(IBE-1)
        DO 180 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 180
  140       CONTINUE
          ELSE
            IF(K(I,2).NE.KFBE(IBE)) GOTO 180
          ENDIF
          IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
          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),2)=0
          K(NBE(IBE),3)=0
          K(NBE(IBE),4)=0
          K(NBE(IBE),5)=0
          P(NBE(IBE),1)=0.0D0
          P(NBE(IBE),2)=0.0D0
          P(NBE(IBE),3)=0.0D0
          P(NBE(IBE),4)=0.0D0
          P(NBE(IBE),5)=0.0D0
          SMMIN=MIN(SMMIN,P(I,5))
C...Check if particles comes from different W's or Z's
          IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
            IM=I
  150       IF(K(IM,3).GT.0) THEN
              IM=K(IM,3)
              IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
              K(NBE(IBE),5)=IM
              IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
              IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
              IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
              IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
            ENDIF
          ENDIF
C...Check if particles comes from different strings.
          IF(PARJ(94).GT.0.0D0) THEN
            IM=I
  160       IF(K(IM,3).GT.0) THEN
              IM=K(IM,3)
              IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
              K(NBE(IBE),5)=IM
            ENDIF
          ENDIF
          DO 170 J=1,3
            P(NBE(IBE),J)=0D0
            V(NBE(IBE),J)=0D0
  170     CONTINUE
          P(NBE(IBE),5)=-1.0D0
  180   CONTINUE
  190 CONTINUE
      IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
 
C...Calculate separation between W+ and W- or between two Z0's.
C...No separation if there has been re-connections.
      SIGW=PARJ(93)
      IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
        IF(K(IWP,2).EQ.23) THEN
          DMW=PMAS(23,1)
          DGW=PMAS(23,2)
        ELSE
          DMW=PMAS(24,1)
          DGW=PMAS(24,2)
        ENDIF
        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)
        IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
      ENDIF
 
C...Add separation between strings.
      IF(PARJ(94).GT.0.0D0) THEN
        SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
        IWP=-1
        IWN=-1
      ENDIF
 
      IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
        DO 220 IBE=1,MIN(9,MSTJ(52))
          DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
            Q2MIN=PECM**2
            I1=K(I1M,1)
            DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
              IF(I2M.EQ.I1M) GOTO 200
              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
  200       CONTINUE
            P(I1M,5)=Q2MIN
  210     CONTINUE
  220   CONTINUE
      ENDIF
 
C...Tabulate integral for subsequent momentum shift.
      DO 400 IBE=1,MIN(9,MSTJ(52))
        IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
        IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
     &  .LE.1) GOTO 270
        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 270
        IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
        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 230 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)
  230   CONTINUE
        DO 240 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)
  240   CONTINUE
        DO 250 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)
  250   CONTINUE
        DO 260 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)
  260   CONTINUE
 
C...Loop through particle pairs and find old relative momentum.
  270   DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
          I1=K(I1M,1)
          DO 380 I2M=I1M+1,NBE(IBE)
            IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
            IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
            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 380
            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 280
            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
  280       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
            IF(QOLD.LT.1D-3*QDEL3) THEN
              GOTO 290
            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
  290       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((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
     &      K(I1M,5).EQ.K(I2M,5)) GOTO 320
 
            IF(QOLD.LT.1D-3*QDELW) THEN
              GOTO 300
            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
  300       Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
            IF(QOLD.LT.1D-3*QDEL3W) THEN
              GOTO 310
            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
  310       Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
            IF(MSTJ(54).EQ.2)
     &      RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
 
  320       CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
            DO 330 J=1,3
              P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
              P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
  330       CONTINUE
            IF(MSTJ(54).GE.1) THEN
              CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
              DO 340 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
  340         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 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
                IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
                IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
                IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
     &          K(I3M,5).NE.K(I1M,5)) GOTO 360
                I3=K(I3M,1)
                IF(K(I3,2).EQ.K(I1,2)) GOTO 360
                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 360
                ELSE
                  IF(WMAX*WI.GE.1.0) GOTO 360
                ENDIF
                DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
                  IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
                  IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
                  IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
     &            K(I4M,5).NE.K(I1M,5)) GOTO 350
                  I4=K(I4M,1)
                  IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
     &            GOTO 350
                  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 350
                  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 350
                  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 350
                  MI3=I3M
                  MI4=I4M
                  WMAX=W
  350           CONTINUE
  360         CONTINUE
              IF(MI4.EQ.0) GOTO 380
              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 370 J=1,3
                V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
                V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
  370         CONTINUE
            ENDIF
  380     CONTINUE
  390   CONTINUE
  400 CONTINUE
 
C...Shift momenta and recalculate energies.
      ESUMP=0.0D0
      ESUM=0.0D0
      PROD=0.0D0
      DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
        I=K(IM,1)
        ESUMP=ESUMP+P(I,4)
        DO 410 J=1,3
          P(I,J)=P(I,J)+P(IM,J)
  410   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 420 J=1,3
          PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
  420   CONTINUE
  430 CONTINUE
 
      PARJ(96)=0.0D0
      IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
  440   ALPHA=(ESUMP-ESUM)/PROD
        PARJ(96)=PARJ(96)+ALPHA
        PROD=0.0D0
        ESUM=0.0D0
        DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
          I=K(IM,1)
          DO 450 J=1,3
            P(I,J)=P(I,J)+ALPHA*V(IM,J)
  450     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 460 J=1,3
            PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
  460     CONTINUE
  470   CONTINUE
        IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
     &  GOTO 440
      ENDIF
 
C...Rescale all momenta for energy conservation.
      PES=0D0
      PQS=0D0
      DO 480 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
        PES=PES+P(I,4)
        PQS=PQS+P(I,5)**2/P(I,4)
  480 CONTINUE
      PARJ(95)=PES-PECM
      FAC=(PECM-PQS)/(PES-PQS)
      DO 500 I=1,N
        IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
        DO 490 J=1,3
          P(I,J)=FAC*P(I,J)
  490   CONTINUE
        P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
  500 CONTINUE
 
C...Boost back to correct reference frame.
  510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
      DO 520 I=1,N
        IF(K(I,1).LT.0) K(I,1)=-K(I,1)
  520 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
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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
        IF(KFA.LE.5) THEN
          PYMASS=PARF(100+KFA)
          IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
        ELSEIF(KFA.LE.10) THEN
          PYMASS=PMAS(KFA,1)
        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.6) 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
        IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
        MSTU(30)=MSTU(30)+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)
          CALL PYSTOP(3)
        ENDIF
 
C...Stop program in case of irreparable error.
      ELSE
        WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
        CALL PYSTOP(3)
      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...Coefficients for second-order threshold matching.
C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
      DIMENSION STEPDN(6),STEPUP(6)
c      DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
c     &(2D0*321D0/3703D0),0D0/
c      DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
c     &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
      DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
      DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
 
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(3,MSTU(113))) THEN
        Q2THR=PARU(113)*PMAS(NF,1)**2
        IF(Q2EFF.LT.Q2THR) THEN
          NF=NF-1
          Q2RAT=Q2THR/ALAM2
          ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
          IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
          GOTO 100
        ENDIF
      ENDIF
  110 IF(NF.LT.MIN(6,MSTU(114))) THEN
        Q2THR=PARU(113)*PMAS(NF+1,1)**2
        IF(Q2EFF.GT.Q2THR) THEN
          NF=NF+1
          Q2RAT=Q2THR/ALAM2
          ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
          IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
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).GE.21.AND.K(I,1).LE.40)) GOTO 110
          IF(MEDIT.EQ.1) THEN
            IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
          ELSEIF(MEDIT.EQ.2) THEN
            IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) 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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &      K(I,2).EQ.KSUSY1+39) GOTO 110
          ELSEIF(MEDIT.EQ.3) THEN
            IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) 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.OR.K(I,1).EQ.52) GOTO 110
            KC=PYCOMP(K(I,2))
            IF(KC.EQ.0) GOTO 110
            IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.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.OR.K(I,1).EQ.51).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,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
          IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) 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).GE.21.AND.K(I,1).LE.40).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.OR.
     &      K(IM,1).EQ.51).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,1).EQ.52.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.AND.
     &      K(I,1).NE.42.AND.K(I,1).NE.52) 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).AND.K(I,1).NE.42.AND.
     &      K(I,1).NE.52) 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
C...Also update LHA1 colour tags
          MCT(I1,1)=MCT(I,1)
          MCT(I1,2)=MCT(I,2)
          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).GE.21.AND.K(I,1).LE.50)) 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).GE.21.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).GE.21.AND.K(KH,1).LE.30) KH=0
          ENDIF
          IF(KH.NE.0) GOTO 280
          I1=I1+1
          IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
          IF(K(I,1).GE.51.AND.K(I,1).LE.60) 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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &      K(I,2).EQ.KSUSY1+39) 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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &      K(I,2).EQ.KSUSY1+39) 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,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
 
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...User process event common block.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/
 
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(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYCTAG/NCT,MCT(4000,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
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)=12345
        IF(MLIST.EQ.0) RETURN
      ENDIF
 
C...List event data, including additional lines after N.
      IF(MLIST.GE.1.AND.MLIST.LE.4) 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)
        IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
        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) GOTO 120
          IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
          IF(MSTU(15).EQ.1.AND.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
          IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
     &    CHAC(LMX-1:LMX-1)='I'
 
C...Write data for particle/jet.
          IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) 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.AND.ABS(P(I,4)).LT.99999D0) THEN
            WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
     &      (P(I,J2),J2=1,5)
          ELSEIF(MLIST.EQ.1) THEN
            WRITE(MSTU(11),5700) 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.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
            IF(MLIST.NE.4) WRITE(MSTU(11),5800) 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)
            IF(MLIST.EQ.4) WRITE(MSTU(11),5900) 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),MCT(I,1),MCT(I,2)
          ELSE
            IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
     &      (P(I,J2),J2=1,5)
            IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
     &           ,MCT(I,1),MCT(I,2)
          ENDIF
          IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (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) THEN
              IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
              IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
              IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
            ENDIF
          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),6600) PS(6),(PS(J),J=1,5)
        ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
          WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
        ELSEIF(MLIST.EQ.1) THEN
          WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
        ELSEIF(MLIST.LE.3) THEN
          WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
        ELSE
          WRITE(MSTU(11),7000) PS(6)
        ENDIF
 
C...Simple listing of HEPEVT entries (mainly for test purposes).
      ELSEIF(MLIST.EQ.5) THEN
        WRITE(MSTU(11),7100)
        DO 140 I=1,NHEP
          IF(ISTHEP(I).EQ.0) GOTO 140
          WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
     &    JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
  140   CONTINUE
 
 
C...Simple listing of user-process entries (mainly for test purposes).
      ELSEIF(MLIST.EQ.7) THEN
        WRITE(MSTU(11),7300)
        DO 150 I=1,NUP
          WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
     &    MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
  150   CONTINUE
 
C...Give simple list of KF codes defined in program.
      ELSEIF(MLIST.EQ.11) THEN
        WRITE(MSTU(11),7500)
        DO 160 KF=1,80
          CALL PYNAME(KF,CHAP)
          CALL PYNAME(-KF,CHAN)
          IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
          IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
  160   CONTINUE
        DO 190 KFLS=1,3,2
          DO 180 KFLA=1,5
            DO 170 KFLB=1,KFLA-(3-KFLS)/2
              KF=1000*KFLA+100*KFLB+KFLS
              CALL PYNAME(KF,CHAP)
              CALL PYNAME(-KF,CHAN)
              WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
  170       CONTINUE
  180     CONTINUE
  190   CONTINUE
        DO 220 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 210 KFLB=1,5
            DO 200 KFLC=1,KFLB-1
              KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
              CALL PYNAME(KF,CHAP)
              CALL PYNAME(-KF,CHAN)
              WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
              IF(KF.EQ.311) THEN
                KFK=130
                CALL PYNAME(KFK,CHAP)
                WRITE(MSTU(11),7600) KFK,CHAP
                KFK=310
                CALL PYNAME(KFK,CHAP)
                WRITE(MSTU(11),7600) KFK,CHAP
              ENDIF
  200       CONTINUE
            KF=10000*KFLR+110*KFLB+KFLS
            CALL PYNAME(KF,CHAP)
            WRITE(MSTU(11),7600) KF,CHAP
  210     CONTINUE
  220   CONTINUE
        KF=100443
        CALL PYNAME(KF,CHAP)
        WRITE(MSTU(11),7600) KF,CHAP
        KF=100553
        CALL PYNAME(KF,CHAP)
        WRITE(MSTU(11),7600) KF,CHAP
        DO 260 KFLSP=1,3
          KFLS=2+2*(KFLSP/3)
          DO 250 KFLA=1,5
            DO 240 KFLB=1,KFLA
              DO 230 KFLC=1,KFLB
                IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
     &          GOTO 230
                IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
                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),7600) KF,CHAP,-KF,CHAN
  230         CONTINUE
  240       CONTINUE
  250     CONTINUE
  260   CONTINUE
        DO 270 KC=1,500
          KF=KCHG(KC,4)
          IF(KF.LT.1000000) GOTO 270
          CALL PYNAME(KF,CHAP)
          CALL PYNAME(-KF,CHAN)
          IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
          IF(CHAN.NE.' ') WRITE(MSTU(11),7600) 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),7700)
        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),7800) 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),7900) 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),8000)
        DO 310 I=1,200
          WRITE(MSTU(11),8100) 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(///28X,'Event listing (no momenta)'//4X,'I  particle/jet',
     &     '  K(I,1)   K(I,2) K(I,3)     K(I,4)      K(I,5)',1X
     &     ,'   C tag  AC tag'/)
 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
 6200 FORMAT(66X,5(1X,F12.3))
 6300 FORMAT(1X,78('='))
 6400 FORMAT(1X,130('='))
 6500 FORMAT(1X,65('='))
 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
     &5F13.5)
 7000 FORMAT(19X,'sum charge:',F6.2)
 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
     &//'    I IST    ID   Mothers Daughters    p_x      p_y      p_z',
     &'       E        m')
 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
     &//'   I IST     ID Mothers   Colours    p_x      p_y      p_z',
     &'       E        m')
 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
 7500 FORMAT(///20X,'List of KF codes in program'/)
 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
 7700 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')
 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
     &1X,1P,E13.5,3X,I2)
 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
     &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
 8100 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=21)
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)/
     &'            *......*            ',
     &'       *:::!!:::::::::::*       ',
     &'    *::::::!!::::::::::::::*    ',
     &'  *::::::::!!::::::::::::::::*  ',
     &' *:::::::::!!:::::::::::::::::* ',
     &' *:::::::::!!:::::::::::::::::* ',
     &'  *::::::::!!::::::::::::::::*! ',
     &'    *::::::!!::::::::::::::* !! ',
     &'    !! *:::!!:::::::::::*    !! ',
     &'    !!     !* -><- *         !! ',
     &'    !!     !!                !! ',
     &'    !!     !!                !! ',
     &'    !!                       !! ',
     &'    !!        lh             !! ',
     &'    !!                       !! ',
     &'    !!                 hh    !! ',
     &'    !!    ll                 !! ',
     &'    !!                       !! ',
     &'    !!                          '/
      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 200x',
     &'                                ',
     &'Now is xx xxx 200x at xx:xx:xx  ',
     &'                                ',
     &'Disclaimer: this program comes  ',
     &'without any guarantees. Beware  ',
     &'of errors and use common sense  ',
     &'when interpreting results.      ',
     &'                                ',
     &'Copyright T. Sjostrand (2008)   '/
      DATA (REFER(J),J=1,14)/
     &'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, the offi',
     &'cial reference is to the 6.4 manual:',
     &'T. Sjostrand, S. Mrenna and P. Skand',
     &'s, JHEP05 (2006) 026                ',
     &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
     &'-T) [hep-ph/0603175].               ',
     &'                                    ',
     &'                                    '/
      DATA (REFER(J),J=15,32)/
     &'Also remember that the program, to a',
     &' large extent, represents original  ',
     &'physics research. Other publications',
     &' of special relevance to your       ',
     &'studies may therefore deserve separa',
     &'te mention.                         ',
     &'                                    ',
     &'                                    ',
     &'Main author: Torbjorn Sjostrand; Dep',
     &'artment of Theoretical Physics,     ',
     &'  Lund University, Solvegatan 14A, S',
     &'-223 62 Lund, Sweden;               ',
     &'  phone: + 46 - 46 - 222 48 16; e-ma',
     &'il: torbjorn@thep.lu.se             ',
     &'Author: Stephen Mrenna; Computing Di',
     &'vision, GDS Group,                  ',
     &'  Fermi National Accelerator Laborat',
     &'ory, MS 234, Batavia, IL 60510, USA;'/
      DATA (REFER(J),J=33,2*IREFER)/
     &'  phone: + 1 - 630 - 840 - 2556; e-m',
     &'ail: mrenna@fnal.gov                ',
     &'Author: Peter Skands; Theoretical Ph',
     &'ysics Department,                   ',
     &'  Fermi National Accelerator Laborat',
     &'ory, MS 106, Batavia, IL 60510, USA;',
     &'  and CERN/PH, CH-1211 Geneva, Switz',
     &'erland;                             ',
     &'  phone: + 41 - 22 - 767 24 59; e-ma',
     &'il: skands@fnal.gov                 '/
 
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!'
        CALL PYSTOP(8)
 
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(8000,2),BRAT(8000),KFDP(8000,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).NE.12345) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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))/MAX(1D-10,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))/MAX(1D-10,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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &    K(I,2).EQ.KSUSY1+39) 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...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)
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(8000,2),BRAT(8000),KFDP(8000,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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &      K(I,2).EQ.KSUSY1+39) 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.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
     &      K(I,2).EQ.KSUSY1+39) 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).NE.12345) 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).NE.12345) 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...PYSTOP
C...Allows users to handle STOP statemens
 
      SUBROUTINE PYSTOP(MCOD)
 
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...Write message, then stop
      WRITE(MSTU(11),5000) MCOD
      STOP

 
C...Formats for output.
 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
      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)
      CALL PYSTOP(6)
 
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)
      CALL PYSTOP(4)
 
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...UPINIT
C...Dummy routine, to be replaced by a user implementing external
C...processes. Is supposed to fill the HEPRUP commonblock with info
C...on incoming beams and allowed processes.

C...New example: handles a standard Les Houches Events File.

      SUBROUTINE UPINIT
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...PYTHIA commonblock: only used to provide read unit MSTP(161).
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      SAVE /PYPARS/
 
C...User process initialization commonblock.
      INTEGER MAXPUP
      PARAMETER (MAXPUP=100)
      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
     &LPRUP(MAXPUP)
      SAVE /HEPRUP/

C...Lines to read in assumed never longer than 200 characters. 
      PARAMETER (MAXLEN=200)
      CHARACTER*(MAXLEN) STRING

C...Format for reading lines.
      CHARACTER*6 STRFMT
      STRFMT='(A000)'
      WRITE(STRFMT(3:5),'(I3)') MAXLEN

C...Loop until finds line beginning with "<init>" or "<init ". 
  100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
      IBEG=0
  110 IBEG=IBEG+1
C...Allow indentation.
      IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110 
      IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
     &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100

C...Read first line of initialization info.
      READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
     &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP

C...Read NPRUP subsequent lines with information on each process.
      DO 120 IPR=1,NPRUP
        READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
     &  XMAXUP(IPR),LPRUP(IPR)
  120 CONTINUE
      RETURN

C...Error exit: give up if initalization does not work.
  130 WRITE(*,*) ' Failed to read LHEF initialization information.'
      WRITE(*,*) ' Event generation will be stopped.'
      CALL PYSTOP(12)
 
      RETURN
      END

C...Old example: handles a simple Pythia 6.4 initialization file.
 
c      SUBROUTINE UPINIT
 
C...Double precision and integer declarations.
c      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
c      IMPLICIT INTEGER(I-N)
 
C...Commonblocks.
c      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
c      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
c      SAVE /PYDAT1/,/PYPARS/
 
C...User process initialization commonblock.
c      INTEGER MAXPUP
c      PARAMETER (MAXPUP=100)
c      INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
c      DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
c      COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
c     &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
c     &LPRUP(MAXPUP)
c      SAVE /HEPRUP/
 
C...Read info from file.
c      IF(MSTP(161).GT.0) THEN
c        READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
c     &  EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
c        DO 100 IPR=1,NPRUP
c          READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
c     &    XMAXUP(IPR),LPRUP(IPR)
c  100   CONTINUE
c        RETURN
C...Error or prematurely reached end of file.
c  110   WRITE(MSTU(11),5000)
c        STOP
 
C...Else not implemented.
c      ELSE
c        WRITE(MSTU(11),5100)
c        STOP
c      ENDIF
 
C...Format for error printout.
c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
c     &1X,'Execution stopped!')
c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
c     &1X,'Dummy routine in PYTHIA file called instead.'/
c     &1X,'Execution stopped!')
 
c      RETURN
c      END
 
C*********************************************************************
 
C...UPEVNT
C...Dummy routine, to be replaced by a user implementing external
C...processes. Depending on cross section model chosen, it either has
C...to generate a process of the type IDPRUP requested, or pick a type
C...itself and generate this event. The event is to be stored in the
C...HEPEUP commonblock, including (often) an event weight.

C...New example: handles a standard Les Houches Events File.

      SUBROUTINE UPEVNT
 
C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...PYTHIA commonblock: only used to provide read unit MSTP(162).
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      SAVE /PYPARS/
 
C...User process event common block.
      INTEGER MAXNUP
      PARAMETER (MAXNUP=500)
      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
      SAVE /HEPEUP/

C...Lines to read in assumed never longer than 200 characters. 
      PARAMETER (MAXLEN=200)
      CHARACTER*(MAXLEN) STRING

C...Format for reading lines.
      CHARACTER*6 STRFMT
      STRFMT='(A000)'
      WRITE(STRFMT(3:5),'(I3)') MAXLEN

C...Loop until finds line beginning with "<event>" or "<event ". 
  100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
      IBEG=0
  110 IBEG=IBEG+1
C...Allow indentation.
      IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110 
      IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
     &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100

C...Read first line of event info.
      READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
     &AQEDUP,AQCDUP

C...Read NUP subsequent lines with information on each particle.
      DO 120 I=1,NUP
        READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
     &  MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
     &  (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
  120 CONTINUE
      RETURN

C...Error exit, typically when no more events.
  130 WRITE(*,*) ' Failed to read LHEF event information.'
      WRITE(*,*) ' Will assume end of file has been reached.'
      NUP=0
      MSTI(51)=1
 
      RETURN
      END

C...Old example: handles a simple Pythia 6.4 event file.
 
c      SUBROUTINE UPEVNT
 
C...Double precision and integer declarations.
c      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
c      IMPLICIT INTEGER(I-N)
 
C...Commonblocks.
c      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
c      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
c      SAVE /PYDAT1/,/PYPARS/
 
C...User process event common block.
c      INTEGER MAXNUP
c      PARAMETER (MAXNUP=500)
c      INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
c      DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
c      COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
c     &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
c     &VTIMUP(MAXNUP),SPINUP(MAXNUP)
c      SAVE /HEPEUP/
 
C...Read info from file.
c      IF(MSTP(162).GT.0) THEN
c        READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
c     &  AQEDUP,AQCDUP
c        DO 100 I=1,NUP
c          READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
c     &    MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
c     &    (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
c  100   CONTINUE
c        RETURN
C...Special when reached end of file or other error.
c  110   NUP=0
 
C...Else not implemented.
c      ELSE
c        WRITE(MSTU(11),5000)
c        STOP
c      ENDIF
 
C...Format for error printout.
c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
c     &1X,'Dummy routine in PYTHIA file called instead.'/
c     &1X,'Execution stopped!')
 
c      RETURN
c      END
 
C*********************************************************************
 
C...UPVETO
C...Dummy routine, to be replaced by user, to veto event generation
C...on the parton level, after parton showers but before multiple
C...interactions, beam remnants and hadronization is added.
C...If resonances like W, Z, top, Higgs and SUSY particles are handed
C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
C...be undecayed at this stage; if decayed their decay products will
C...have been allowed to shower.
 
C...All partons at the end of the shower phase are stored in the
C...HEPEVT commonblock. The interesting information is
C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
C...IDHEP(I) = the particle ID code according to PDG conventions,
C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
C...All ISTHEP entries are 1, while the rest is zeroed.
 
C...The user decision is to be conveyed by the IVETO value.
C...IVETO = 0 : retain current event and generate in full;
C...      = 1 : abort generation of current event and move to next.
 
      SUBROUTINE UPVETO(IVETO)
 
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...Next few lines allow you to see what info PYVETO extracted from
C...the full event record for the first two events.
C...Delete if you don't want it.
      DATA NLIST/0/
      SAVE NLIST
      IF(NLIST.LE.2) THEN
        WRITE(*,*) ' Full event record at time of UPVETO call:'
        CALL PYLIST(1)
        WRITE(*,*) ' Part of event record made available to UPVETO:'
        CALL PYLIST(5)
        NLIST=NLIST+1
      ENDIF
 
C...Make decision here.
      IVETO = 0
 
      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)
      CALL PYSTOP(5)
      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)
      CALL PYSTOP(5)
      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)
      CALL PYSTOP(5)
      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...SUGRA
C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
 
      SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
       IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
      INTEGER IMODL
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(110)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
     &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
     &1X,'Execution stopped!')
 
      RETURN
      END
 
C*********************************************************************
 
C...VISAJE
C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
 
      FUNCTION VISAJE()
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      CHARACTER*40 VISAJE
 
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Assign default value.
      VISAJE='Undefined'
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(110)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
     &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
     &1X,'Execution stopped!')
 
      RETURN
      END
 
C*********************************************************************
 
C...SSMSSM
C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
 
      SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
     &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
     &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
     &IDUM1,IDUM2)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
     &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
     &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(110)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
     &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
     &1X,'Execution stopped!')
      RETURN
      END
 
C*********************************************************************
 
C...FHSETFLAGS
C...Dummy function, to be removed when FEYNHIGGS is to be linked.
 
      SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
Cmssmpart = 4     # full MSSM [recommended]
Cfieldren = 0     # MSbar field ren. [strongly recommended]
Ctanbren =  0     # MSbar TB-ren. [strongly recommended]
Chiggsmix = 2     # 2x2 (h0-HH) mixing in the neutral Higgs sector
Cp2approx = 0     # no approximation [recommended]
Clooplevel= 2     # include 2-loop corrections
Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
 
C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(103)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
     &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
     &1X,'Execution stopped!')
      RETURN
      END
 
C*********************************************************************
 
C...FHSETPARA
C...Dummy function, to be removed when FEYNHIGGS is to be linked.
 
      SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
     &     DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
     &     DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
     &     DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
      DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
      DOUBLE COMPLEX DMU,
     &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
     &     DM1, DM2, DM3

C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(103)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
     &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
     &1X,'Execution stopped!')
      RETURN
      END
 
C*********************************************************************
 
C...FHHIGGSCORR
C...Dummy function, to be removed when FEYNHIGGS is to be linked.
 
      SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
 
C...FeynHiggs variables
      DOUBLE PRECISION RMHIGG(4)
      DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
      DOUBLE COMPLEX DMU,
     &     AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
     &     DM1, DM2, DM3

C...Commonblocks.
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      SAVE /PYDAT1/
 
C...Stop program if this routine is ever called.
      WRITE(MSTU(11),5000)
      CALL PYSTOP(103)
 
C...Format for error printout.
 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
     &1X,'Dummy routine FHSETPARA 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)
      CALL PYSTOP(10)
 
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),IVAL(8)
 
C...Example 0: if you do not have suitable routines.
      DO 100 J=1,6
      IDATI(J)=0
  100 CONTINUE
 
C...Example 1: Fortran 90 routine.
C      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      IDATI(1)=IYEAR
C      IDATI(2)=IMON
C      IDATI(3)=IDAY
C      CALL ITIME(IHOUR,IMIN,ISEC)
C      IDATI(4)=IHOUR
C      IDATI(5)=IMIN
C      IDATI(6)=ISEC
 
C...Example 3: DEC Fortran, IRIX, IRIX64.
C      CALL IDATE(IMON,IDAY,IYEAR)
C      IDATI(1)=IYEAR
C      IDATI(2)=IMON
C      IDATI(3)=IDAY
C      CALL TIME(ATIME)
C      IHOUR=0
C      IMIN=0
C      ISEC=0
C      READ(ATIME(1:2),'(I2)') IHOUR
C      READ(ATIME(4:5),'(I2)') IMIN
C      READ(ATIME(7:8),'(I2)') ISEC
C      IDATI(4)=IHOUR
C      IDATI(5)=IMIN
C      IDATI(6)=ISEC
 
C...Example 4: GNU LINUX libU77, SunOS.
C      CALL IDATE(IDTEMP)
C      IDATI(1)=IDTEMP(3)
C      IDATI(2)=IDTEMP(2)
C      IDATI(3)=IDTEMP(1)
C      CALL ITIME(IDTEMP)
C      IDATI(4)=IDTEMP(1)
C      IDATI(5)=IDTEMP(2)
C      IDATI(6)=IDTEMP(3)
 
C...Common code to ensure right century.
      IDATI(1)=2000+MOD(IDATI(1),100)
 
      RETURN
      END