sPhenix code displayed by LXR master/​coresoftware/​generators/​JEWEL/​pythia6425mod.f	Source navigation Diff markup Identifier search General search
	Version: master Revert   Change

File indexing completed on 2025-08-03 08:16:34

 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 C++ This version of PYTHIA 6.4.25 was modified to run with the      ++
 C++ jet quenching Monte Carlo JEWEL. It is not an official release  ++
 C++ of PYTHIA and may not be used for anything else.                ++
 C++                                                                 ++
 C++ Modifications with respect to the official PYTHIA version:      ++
 C++ * The event record was enlarged to 23000 lines.                 ++
 C++ * The LHAPDF interface was activated and modified such that     ++
 C++   nuclear PDF's can be used.                                    ++
 C++ * A customised version of PYEVWT was introduced to allow for    ++
 C++   the generation of weighted events.                            ++
 C++                                                                 ++
 C++                                                    Korinna Zapp ++
 C++                                                     (Oct. 2013) ++
 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 C
 C*********************************************************************
 C*********************************************************************
 C*                                                                  **
 C*                                                       Mar 2011   **
 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*               CERN/PH, CH-1211 Geneva, Switzerland               **
 C*                    phone +41 - 22 - 767 2447                     **
 C*                   E-mail peter.skands@cern.ch                    **
 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 2010             **
 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, 23000,23000,  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,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
      &9*15/     
       DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-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,-13,13,-15,15,3*-1,3*-3,     
      &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,     
      &-13,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,  425, 2011,   03,   23,    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.25D0,
      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,   -2,
      8  2,    2,  18*-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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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...Initialize variable(s)
       INEW = 1
  
 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) THEN
              K(I,1)=11
              IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND.
      $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND.
      $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12
           ENDIF
           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 setlhaparm('SILENT')
         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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(MAX(1D0,PARP(67))*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) THEN
 C...........No reason to count this as an error
             LOOPHS = LOOPHS-1
             GOTO 100
           ENDIF
 
  
 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
 C...Also collapse particles decaying to themselves (if same KS)
 C...Sep 22 2009: Commented out by PS following suggestion by TS to fix 
 C...problem with history point-backs in new shower, where a particle is
 C...copied with a new momentum when it is the recoiler.
 C            ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
 C     &            .AND.K(I,4).LT.N) THEN
 C              IDA=K(I,4)
 C              IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
 C                K(I,1)=0
 C              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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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.
       CHARACTER PRTMP*9
       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...Initialize Generic Processes
       KFGEN=9900001
       KCGEN=PYCOMP(KFGEN)
       IF(KCGEN.GT.0) THEN
         IDCY=MDCY(KCGEN,2)
         IF(IDCY.GT.0) THEN
           KFF1=KFDP(IDCY+1,1)
           KFF2=KFDP(IDCY+1,2)
           KCF1=PYCOMP(KFF1)
           KCF2=PYCOMP(KFF2)
           IJ1=1
           IJ2=1
           KCI1=PYCOMP(KFDP(IDCY,1))
           IF(KFDP(IDCY,1).LT.0) IJ1=2
           KCI2=PYCOMP(KFDP(IDCY,2))
           IF(KFDP(IDCY,2).LT.0) IJ2=2
           ITMP1=0
  190      ITMP1=ITMP1+1
           IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
      &    GOTO 190
           ITMP2=0
  200      ITMP2=ITMP2+1
           IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
      &    GOTO 200          
           PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
           ITMP3=0
  205      ITMP3=ITMP3+1
           IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
      &    GOTO 205
           PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
           IJ1=1
           IJ2=1
           IF(KFF1.LT.0) IJ1=2
           IF(KFF2.LT.0) IJ2=2
           ITMP1=0
  210      ITMP1=ITMP1+1
           IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
      &    GOTO 210
           ITMP2=0
  220      ITMP2=ITMP2+1
           IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
      &    GOTO 220          
           PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
      &    '+'//CHAF(KCF2,IJ2)(1:ITMP2)
         ENDIF
       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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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/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/PYINT6/PROC(0:500)
       CHARACTER PROC*28
       SAVE /PYDAT1/,/PYDAT2/,/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,296
             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...Initialize Generic Processes
       KFGEN=9900001
       KCGEN=PYCOMP(KFGEN)
       IF(KCGEN.GT.0) THEN
         IDCY=MDCY(KCGEN,2)
         IF(IDCY.GT.0) THEN
           KFF1=KFDP(IDCY+1,1)
           KFF2=KFDP(IDCY+1,2)
           KCF1=PYCOMP(KFF1)
           KCF2=PYCOMP(KFF2)
           JCOL1=IABS(KCHG(KCF1,2))
           IF(JCOL1.EQ.1) THEN
             KF1=KFF1
             KF2=KFF2
           ELSE
             KF1=KFF2
             KF2=KFF1
           ENDIF
           KFPR(481,1)=KF1
           KFPR(481,2)=KF2
           KFPR(482,1)=KF1
           KFPR(482,2)=KF2
         ENDIF
         IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
           KFIN(1,0)=1
           KFIN(2,0)=1
         ENDIF
       ENDIF
  
 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
         ELSEIF(ISUB.EQ.481) THEN
           KFR1=9900001
         ENDIF
         CKMX=CKIN(2)
         IF(CKMX.LE.0D0) CKMX=VINT(1)
         KCR1=PYCOMP(KFR1)
         IF(KCR1.EQ.0) KFR1=0
         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(23000,5),P(23000,5),V(23000,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
       ELSEIF(ISUB.EQ.481) THEN
         KFR1=9900001
       ENDIF
       CKMX=CKIN(2)
       IF(CKMX.LE.0D0) CKMX=VINT(1)
       KCR1=PYCOMP(KFR1)
       IF(KCR1.EQ.0) KFR1=0
       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
  
       IF(ISTSB.LE.10) THEN
 C...  If internal process, call PYSIGH
         CALL PYSIGH(NCHN,SIGS)
       ELSE
 C...  If external process, still have to set MI starting scale 
         IF (MSTP(86).EQ.1) THEN
 C...  Limit phase space by xT2 of hard interaction
 C...  (gives undercounting of MI when ext proc != dijets)
           XT2GMX = VINT(25)
         ELSE
 C...  All accessible phase space allowed
 C...  (gives double counting of MI when ext proc = dijets)
           XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
         ENDIF
         VINT(62)=0.25D0*XT2GMX*VINT(2)
         VINT(61)=SQRT(MAX(0D0,VINT(62)))
       ENDIF
       
       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(23000,5),P(23000,5),V(23000,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
         IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
          VINT(38+JT)=XSFX(JT,MINT(14+JT))
         ELSE
          VINT(38+JT)=1D0
         ENDIF
   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.301) 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)
  
         ELSEIF(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.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.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
 C...QUARKONIA---
         ENDIF
       ELSEIF(ISUB.LE.500) THEN
         IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
           KFRES=9900001
           KCRES=PYCOMP(KFRES)
           MCOL=KCHG(KCRES,2)
           MCHG=KCHG(KCRES,1)
           IF(KCRES.EQ.0) 
      $      CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
           IDCY=MDCY(KCRES,2)
           IF(IDCY.EQ.0)
      $      CALL PYERRM(21,"No decays for resonance in Generic 2->2")
           KCI1=PYCOMP(MINT(15))
           KCI2=PYCOMP(MINT(16))
           ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
           ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
           KFF1=KFPR(ISUB,1)
           KFF2=KFPR(ISUB,2)
           KCF1=PYCOMP(KFF1)
           KCF2=PYCOMP(KFF2)
           JCOL1=SIGN(KCHG(KCF1,2),KFF1)
           IF(JCOL1.EQ.-2) JCOL1=2
           JCOL2=SIGN(KCHG(KCF2,2),KFF2)
           IF(JCOL2.EQ.-2) JCOL2=2
           KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
           KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
           KCHW=KCH1+KCH2
           KREL=1
           IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
           IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
           IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
           IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
           IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
           IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
      $      (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
             IF(PYR(0).GT.0.5D0) JS=2
             MINT(20+JS)=KFF1
             MINT(23-JS)=KFF2
             IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
 
             ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
               KCC=17+JS
               MINT(20+JS)=KFF2
               MINT(23-JS)=KFF1
             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
               KCC=17+JS
               MINT(20+JS)=KFF1
               MINT(23-JS)=KFF2
             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
 
             ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
               KCC=MINT(2)+4
             ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
      $        (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
               IF(ICOL1.EQ.JCOL1) THEN
                 JS=1
                 MINT(21)=KFF1
                 MINT(22)=KFF2
               ELSE
                 JS=2
                 MINT(21)=KFF2
                 MINT(22)=KFF1
               ENDIF
               IF(MCOL.EQ.0) THEN
         
               ELSE
                 KCC=4
               ENDIF
             ENDIF
           ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
      $      (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
             IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
      $        (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
               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))
               IF(JCOL1.EQ.2) THEN
                 MINT(20+JS)=KFF2
                 MINT(23-JS)=KFF1
               ELSE
                 MINT(20+JS)=KFF1
                 MINT(23-JS)=KFF2
               ENDIF
             ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
      $        (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
               IF(MINT(15).EQ.21) JS=2
               KCC=15+JS
               KCS=ISIGN(1,MINT(14+JS))
               IF(JCOL1.EQ.0) THEN
                 MINT(23-JS)=KFF1
                 MINT(20+JS)=KFF2
               ELSE
                 MINT(23-JS)=KFF2
                 MINT(20+JS)=KFF1
               ENDIF
             ENDIF
           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
      $      JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
             IF(PYR(0).GT.0.5D0) JS=2             
             KCC=21
             MINT(20+JS)=KFF1
             MINT(23-JS)=KFF2
           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
      $      ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
      $      ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
             IF(PYR(0).GT.0.5D0) JS=2
             KCC=22+JS
             KCS=(-1)**INT(1.5D0+PYR(0))
             IF(JCOL1.EQ.0) THEN
               MINT(23-JS)=KFF1
               MINT(20+JS)=KFF2
             ELSE
               MINT(23-JS)=KFF2
               MINT(20+JS)=KFF1
             ENDIF
           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
      $      ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
      $      ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
 C....two choices, 0 or 2 depending upon mother properties
             IF(MCOL.EQ.2) THEN
               KCS=(-1)**INT(1.5D0+PYR(0))
               KCC=MINT(2)+10
               IF(JCOL1.EQ.1) THEN
                 MINT(21)=KFF1*KCS
                 MINT(22)=KFF2*KCS
               ELSE
                 MINT(22)=KFF1*KCS
                 MINT(21)=KFF2*KCS
               ENDIF
 c              MINT(20+JS)=KFF1*KCS
 c              MINT(23-JS)=KFF2*KCS
             ELSEIF(MCOL.EQ.0) THEN
               KCC=21
               MINT(20+JS)=KFF1*KCS
               MINT(23-JS)=KFF2*KCS
             ENDIF
 
           ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
      $      JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
 C....two choices, 0 or 2 depending upon mother properties
             IF(MCOL.EQ.0) THEN
               KCC=21
               IF(PYR(0).GT.0.5D0) JS=2
               MINT(20+JS)=KFF1
               MINT(23-JS)=KFF2               
             ELSEIF(MCOL.EQ.2) THEN
               IF(PYR(0).GT.0.5D0) JS=2
               KCC=MINT(2)+12
               KCS=(-1)**INT(1.5D0+PYR(0))
               MINT(20+JS)=KFF1
               MINT(23-JS)=KFF2
             ENDIF
           ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
      $      (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
             KCC=MINT(2) 
             IF(PYR(0).GT.0.5D0) JS=2
             MINT(20+JS)=KFF1
             MINT(23-JS)=KFF2                          
           ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
             KCC=20
             IF(PYR(0).GT.0.5D0) JS=2
             MINT(20+JS)=KFF1
             MINT(23-JS)=KFF2                          
           ELSE
             CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
           ENDIF
           IF(ISUBSV.EQ.482) KFRES=0
         ENDIF 
       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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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)
         IF (MSTP(67).NE.0) THEN
           PT2 = MIN(PT2NOW,VINT(56))
         ELSE
 C...For MSTP(67)=0, adjust starting scale by PARP(67)
           PT2=MIN(PT2NOW,PARP(67)*VINT(56))
         ENDIF
         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
 C...Check that not below mass threshold.
           IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
             CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
      &        'No Q creation possible.')
             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
 
         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.
         NJN=0
         IF (MSTP(96).NE.0) THEN
           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(MSTP(61).EQ.1) WTAPE=0D0
           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.AND.MSTP(61).GE.2) 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...If massive quark also on opposite side, ensure sufficient remaining 
 C...phase space also for creation of that quark
           TMINQQ = TMIN
           KFLOPP = K(IMI(3-JS,MI,1),2)
           IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
 C...Ensure mininimum PT2CR and force creation near threshold.
           IF (PT2CR.LT.TMINQQ*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=TMINQQ*RMQ2
 C...Signal that massive quark creation is being forced
             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-PT2MX).LT.-0.001.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 momentum transfer: sdip = -t = - (p1 - p2)^2
 C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
           SDIP=ABS(((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 (4D0*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 (4D0*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...Special for PT2 = PT2MX (e.g., if two incoming massive quarks 
 C...simultaneously reached their creation thresholds) 
         IF (ABS(PT2-PT2MX).LT.0.001) THEN
           IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
         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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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 NCHN,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)
         NCHN=0
         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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(4),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),VDCY(4),
      &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
      &KFL4(3)
       COMPLEX FGK,HA(6,6),HC(6,6)
       REAL TIR,UIR
       CHARACTER CODE*9,MASS*9
 C...Local arrays.
       DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
       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)
  
 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
         KFL4(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
  
         NPROD=0
 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))
         NPROD=NPROD+1
         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
         NPROD=NPROD+1
         KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
         KCQ3(JT)=0
         KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
         KCQ4(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
           NPROD=NPROD+1
           IF(KFL4(JT).NE.0) THEN
             KFC4A=PYCOMP(IABS(KFL4(JT)))
             IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
             KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
             IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
             NPROD=NPROD+1
           ENDIF
         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
  
         PXSUM=0D0
 C...Select masses; to begin with assume resonances narrow.
         DO 220 I=1,4
           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
           ELSEIF(I.EQ.4) THEN
             IF(KFL4(JT).EQ.0) GOTO 220
             KFLW=IABS(KFL4(JT))
             KCW=KFC4A
           ENDIF
           P(N+I,5)=PMAS(KCW,1)
           PXSUM=PXSUM+P(N+I,5)
 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)
                 IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
      &              PMAS(PYCOMP(KFDP(IDC,4)),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
         IF(KFL4(JT).NE.0) THEN
           PWID4=PMAS(KFC4A,2)
           IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
             IWID1=4
             PWID1=PWID4
             KFLW1=IABS(KFL4(JT))
           ELSEIF(PWID4.GT.PWID2) THEN
             IWID2=4
             PWID2=PWID4
             KFLW2=IABS(KFL4(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(PXSUM.GT.P(ID,5)) THEN
             CALL PYERRM(13,'(PYRESD:) daughter masses too large')
             MINT(51)=1
             GOTO 720
           ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
             CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) 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.OR.KFL4(JT).NE.0) THEN
           DO 250 I=N+1,N+NPROD
             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)
           IF(KFL4(JT).NE.0) THEN
             K(N+4,1)=1
             K(N+4,2)=KFL4(JT)
           ENDIF
           IDIN=ID
 
 C...Generate kinematics (default is flat)
           IF(KFL4(JT).EQ.0) THEN
             CALL PYTBDY(IDIN)
           ELSE
             PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
             ND=4
             PV(1,1)=0D0
             PV(1,2)=0D0
             PV(1,3)=0D0
             PV(1,4)=P(IDIN,5)
             PV(1,5)=P(IDIN,5)
 C...Calculate maximum weight ND-particle decay.
             PV(ND,5)=P(N+ND,5)
             WTMAX=1D0/WTCOR(ND-2)
             PMAX=PV(1,5)-PS+P(N+ND,5)
             PMIN=0D0
             DO 381 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))
  381        CONTINUE
 
 C...M-generator gives weight. If rejected, try again.
 
  411        RORD(1)=1D0
             DO 441 IL1=2,ND-1
               RSAV=PYR(0)
               DO 421 IL2=IL1-1,1,-1
                 IF(RSAV.LE.RORD(IL2)) GOTO 431
                 RORD(IL2+1)=RORD(IL2)
  421          CONTINUE
  431          RORD(IL2+1)=RSAV
  441        CONTINUE
             RORD(ND)=0D0
             WT=1D0
             DO 451 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))
  451        CONTINUE
             IF(WT.LT.PYR(0)*WTMAX) GOTO 411
 
 C...Perform two-particle decays in respective CM frame.
             DO 481 IL=1,ND-1
               PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
               UE(3)=2D0*PYR(0)-1D0
               PHIX=PARU(2)*PYR(0)
               UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
               UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
               DO 471 J=1,3
                 P(N+IL,J)=PA*UE(J)
                 PV(IL+1,J)=-PA*UE(J)
  471          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)
  481        CONTINUE
 
 C...Lorentz transform decay products to lab frame.
             DO 491 J=1,4
               P(N+ND,J)=PV(ND,J)
  491        CONTINUE
             DO 531 IL=ND-1,1,-1
               DO 501 J=1,3
                 BE(J)=PV(IL,J)/PV(IL,4)
  501          CONTINUE
               GA=PV(IL,4)/PV(IL,5)
               DO 521 I=N+IL,N+ND
                 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
                 DO 511 J=1,3
                   P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
  511            CONTINUE
                 P(I,4)=GA*(P(I,4)+BEP)
  521          CONTINUE
  531        CONTINUE
 
           ENDIF
 
 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)
           KCQ(4)=KCQ4(JT)
           DO 255 J=0,NPROD
             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
          ELSEIF(NTRI+NANT.EQ.4) THEN
 C...
             IF (KCQ(0).EQ.1) THEN
 C...3 -> 3 + n(1) -> 3 + 3bar
               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)
               K(ITRI(3),1)=3
               K(ITRI(3),4)=MSTU(5)*IANT(1)
               K(IANT(1),1)=3
               K(IANT(1),5)=MSTU(5)*ITRI(3)
               NCT=NCT+1
               MCT(ITRI(3),1)=NCT
               MCT(IANT(1),2)=NCT
             ELSEIF (KCQ(0).EQ.-1) THEN
 C...3bar -> 3bar + n(1) -> 3 + 3bar             
               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)
               K(ITRI(1),1)=3
               K(ITRI(1),4)=MSTU(5)*IANT(3)
               K(IANT(3),1)=3
               K(IANT(3),5)=MSTU(5)*ITRI(1)
               NCT=NCT+1
               MCT(ITRI(1),1)=NCT
               MCT(IANT(3),2)=NCT
             ENDIF
           ELSEIF(KFL4(JT).NE.0) THEN
             CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
 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+NPROD
 
 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++
         NPROD=2
         IF(KFL3(JT).NE.0) NPROD=3
         IF(KFL4(JT).NE.0) NPROD=4
         CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
      &       DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
         N0=NSD(JT)+NPROD
  
         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)+NPROD
           IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
 C...If 3-body or 2-body with junction:
 c          IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
 C...If 3-body with junction:
 c          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)+NPROD
 c          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
 C...If 4-body or 3-body with junction:
           IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
 C...If 4-body with junction:
           IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,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,-NPROD,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=NPROD
 c          IF(KFL3(JT).NE.0) NPART=3
           IPART(1)=NSD(JT)+1
           IPART(2)=NSD(JT)+2
           IPART(3)=NSD(JT)+3
           IPART(4)=NSD(JT)+4
           PTPART(1)=0.5D0*P(ID,5)
           PTPART(2)=PTPART(1)
           PTPART(3)=PTPART(1)
           PTPART(4)=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(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
      &    (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
             MOTHER=K(NSD(JT)+4,4)/MSTU(5)
             MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
           ENDIF
           IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
      &    (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
             MOTHER=K(NSD(JT)+4,5)/MSTU(5)
             MCT(NSD(JT)+4,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
         NSD4=NSD(JT)+4
 C...4-body decays will only work if one of the products is "inert"
         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
           IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
             DO 685 I=NSHBEF+1,NSHAFT
               IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
      &        I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
   685       CONTINUE
           ENDIF
         ENDIF
  
 C...Store decay products for further treatment.
         IF(KFL4(JT).EQ.0) THEN
           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)
         ELSE
           NSDA=NSD1
           NSDB=NSD2
           NSDC=NSD3
           NP=NP+1
           IREF(NP,4)=IDOC+1
           IREF(NP,5)=IDOC+2
           IREF(NP,6)=IDOC+3
           IF(K(NSD1,1).EQ.1) THEN
             NSDA=NSD4
             IREF(NP,4)=IDOC+4
           ELSEIF(K(NSD2,1).EQ.1) THEN
             NSDB=NSD4
             IREF(NP,5)=IDOC+4
           ELSEIF(K(NSD3,1).EQ.1) THEN
             NSDC=NSD4
             IREF(NP,6)=IDOC+4
           ENDIF
           IREF(NP,1)=NSDA
           IREF(NP,2)=NSDB
           IREF(NP,3)=NSDC
           IREF(NP,7)=K(IREF(IP,JT),2)
           IREF(NP,8)=IREF(IP,JT)
         ENDIF
   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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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...         = 8  : Type P             ; hadron-hadron only
 C...         = 9  : Type P             ; 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...Type P is also driven by free triplets, but the reconnect probability
 C...is computed from the string density per unit rapidity, where the axis
 C...with respect to which the rapidity is computed is the Thrust axis of the
 C...event. 
 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.
 C...For types I, II, and S, N is chosen simply as the number of multiple 
 C...interactions, for a rough scaling with the general level of activity.
 C...For type P, N is chosen to be the number of string pieces in a given 
 C...interval of rapidity (minus one, since the string doesn't reconnect 
 C...with itself), and the reconnect probability is interpreted as the 
 C...probability per unit rapidity. 
 C...It also also possible to apply a dampening factor to the CR strength,
 C...using PARP(77), which will cause reconnections among high-pT string
 C...pieces to be suppressed. 
 
       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(23000,5),P(23000,5),V(23000,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 strings
       PARAMETER (NBINY=100)
       INTEGER ICR(4000),MSCR(4000)
       INTEGER IOPT(4000), NSTRY(NBINY)
       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 Paquis type, determine thrust axis (default along Z axis)
       TX=0D0
       TY=0D0
       TZ=1D0
       IF (MSTP95.GE.8) THEN
         CALL PYTHRU(THRDUM,OBLDUM)
         TX = P(N+1,1)
         TY = P(N+1,2)
         TZ = P(N+1,3)
       ENDIF
       
 C...For each final-state dipole, check whether string should be
 C...preserved.
       NCR=0
       IA=0
       IC=0
       RAPMAX=0.0
 
       ICTMIN=NCT
       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
 C...Save smallest NCT value so far
           ICTMIN = MIN(ICTMIN,ICT)
 C...For Paquis algorithm, just store all string pieces for now
           IF (MSTP95.GE.8) THEN 
 C...  Add coloured parton
             NCR=NCR+1
             ICR(NCR)=IC
             MSCR(NCR)=1
             IOPT(NCR)=0
 C...  Store rapidity (along Thrust axis) in RLOPT for the time being
 C...  Add pion mass headroom to energy for this calculation
             EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
             PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
             RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
 C...  Add anti-coloured parton
             NCR       = NCR+1
             ICR(NCR)  = IA   
             MSCR(NCR) = 2
             IOPT(NCR) = 0
 C...  Store rapidity (along Thrust axis) in RLOPT for the time being
             EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
             PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
             RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
 C...  Keep track of largest endpoint "rapidity"
             RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
             RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
           ELSE
             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
         ENDIF
   150 CONTINUE
 
 C...PAQUIS TYPE
       IF (MSTP95.GE.8) THEN
 C...  For Paquis type, make "histogram" of string densities along thrust axis
         RAPMIN = -RAPMAX
         DRAP   = 2*RAPMAX/(1D0*NBINY)
 C...  Explicitly zero histogram bin content
         DO 147 IBINY=1,NBINY
           NSTRY(IBINY)=0
  147    CONTINUE
         DO 152 ISTR=1,NCR-1,2
           IC = ICR(ISTR)
           IA = ICR(ISTR+1)
           Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
           Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
           DO 153 IBINY=1,NBINY
             YBINLO = RAPMIN + (IBINY-1)*DRAP
 C...  If bin inside string piece, add 1 in this bin
 C...  (Strictly speaking: if it starts before midpoint and ends after midpoint)
             IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
      &           NSTRY(IBINY) = NSTRY(IBINY) + 1
  153      CONTINUE
  152    CONTINUE
 C...  Loop over pieces to find individual reconnect probability
         DO 167 IS=1,NCR-1,2
           DNSUM  = 0D0
           DNAVG  = 0D0
 C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
           RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
           RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5    
 C...Make sure integer bin numbers lie inside proper range
           IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
           IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
 C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
 C...(also smaller than DRAP if a one-unit wide piece is stretched 
 C... over 2 bins, thus making the computation more accurate)
           DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
 C...  Decide whether to suppress reconnections in high-pT string pieces
           CRMODF = 1D0
           IF (PARP(77).GT.0D0) THEN
 C...  Total string piece energy, momentum squared, and components
             EES  =  P(ICR(IS),4) + P(ICR(IS+1),4)
             PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
      &           + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
      &           + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
             PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ 
      &           + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
             PTTS = SQRT(PPS2 - PZTS**2)
 C...  Mass of string piece in units of mpi (at least 1)
             RMPI2  = 0.135D0 
             RM2STR = MAX(RMPI2,EES**2 - PPS2)
 C...  Estimate number of pions ~ log(M2) (at least 1)
             RNPI   = LOG(RM2STR/RMPI2)+1D0
             PT2AVG = (PTTS / RNPI)**2
 C...  Supress reconnection probability by 1/(1+P77*P2AVG)        
             CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
           ENDIF
           PKEEP = 1.0
           DO 178 IBINY=IBINLO,IBINHI
 C            DNSUM = DNSUM + 1D0
             DNOVL = MAX(0,NSTRY(IBINY)-1)
             PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
 C            DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
  178      CONTINUE
 C          DNAVG = DNAVG / DNSUM
 C...  If keeping string piece, save
           IF (PYR(0).LE.PKEEP) THEN
             LCT = LCT+1
             MCN(ICR(IS),1)=LCT
             MCN(ICR(IS+1),2)=LCT
           ENDIF
  167    CONTINUE
       ENDIF
 
 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...PS: 03 May 2010
 C...For Seattle and Paquis types, check if there is a dangling tag
 C...Needed for special case when entire reconnected state was one or
 C...more gluon loops in original topology in which case these CR
 C...algorithms need to be told they shouldn't look for a dangling tag.
       M3FREE=0
       IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
         DO 157 IC1=1,NCR
           I1=ICR(IC1)
 C...Color charge
           MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
           IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
           IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
           IF (MCI.EQ.2) THEN
             IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
             IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
           ENDIF
  157    CONTINUE
       ENDIF
 
 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 (unless there aren't any, cf. M3FREE above.)
         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
      &         .AND.M3FREE.EQ.1) THEN
             GOTO 230
           ENDIF
         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...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
 C...Paquis type: fix problem above
               MPAQ = 0
               IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
                 IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
                 IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
               ENDIF
               IF (MPAQ.EQ.0) THEN
                 RLOPT=RL
                 RLOPTC(IC1)=RLOPT
                 IOPT(IC1)=J
                 MBROPT=MBRSTR
                 MGGOPT=MGGSTR
               ENDIF
             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
       ICMAX=0
       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)
             ICMAX=0
             RLMAX=1D19
 C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
             DO 250 KCT=ICTMIN,LCT
               IC=0
               IA=0
               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
 C...Skip if this color tag no longer present in event record
               IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250
               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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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)
 C...Skip dummy modes or unrecognized particles
           IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
           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'
               CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
               FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
               FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
               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
               FCOF2=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*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
      &           *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))            
             IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
 C...PS 28/06/2010
 C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
               WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
      &             *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))            
             ENDIF
           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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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    7,  7,  18*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)
 C...Default is to use standard PDFs, but for interactions after the first
 C...in the new multiple-parton-interactions framework, set which side to
 C...evaluate the MPI-modified PDFs on.
           MINT(30)=0
           IF (MINT(31).GE.1) MINT(30)=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)
 C...PS (12 Feb 2010)
 C...New options MSTP(33) = 10 and 11
 C...  10: use K-factor = PARP(32) only for process 96 (MPI)
 C...  11: as for 10, but also use K-factor = PARP(31) for other procs
       ELSEIF(MSTP(33).GE.10) THEN
         IF (ISUB.EQ.96) THEN
           FACK = PARP(32)
         ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
           FACK = PARP(31)
         ENDIF
       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).OR.
      &      KFAC(1,I)*KFAC(2,-I).EQ.0) 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
 C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
             FACQQ1=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...4=RKF because ~t ~tbar and ~b ~bbar 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
       ELSEIF(ISUB.LE.500) THEN
         IF(ISUBSV.EQ.481) ISUB=482
 c...  GENERIC 2->(1)->2
         IF(ISUB.EQ.482) THEN
           KFRES=9900001
           KCRES=PYCOMP(KFRES)
           IF(KCRES.EQ.0) RETURN
           IDCY=MDCY(KCRES,2)
           KCOL=KCHG(KCRES,2)
           KCEM=KCHG(KCRES,1)
           FACT=COMFAC
           KCF1=PYCOMP(KFPR(ISUB,1))
           KCF2=PYCOMP(KFPR(ISUB,2))
           IF(ISUBSV.EQ.481) THEN
             SQMZR=PMAS(KCRES,1)**2
             CALL PYWIDT(KFRES,SH,WDTP,WDTE)
             HS=SHR*WDTP(0)
             FACBW=SH2/((SH-SQMZR)**2+HS**2)
             FACT=FACT*FACBW
           ELSE
             SQMH=PMAS(KCF1,1)**2
             GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
 C...Propagators: as simulated in PYOFSH and as desired
             HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
             CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
             GMMH3=SQRT(SQM3)*WDTP(0)
             HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
             SQMH=PMAS(KCF2,1)**2
             GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
             HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
             CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
             GMMH4=SQRT(SQM4)*WDTP(0)
             HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
             FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
           ENDIF
 
           KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
           KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
           JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
           JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
           IF(KCOL.EQ.0) THEN
             NCOL=1
           ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
             IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
               NCOL=3
             ELSE
               NCOL=2
             ENDIF
           ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
             NCOL=2
           ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
      $      JCOL2.EQ.0) THEN
             NCOL=1
           ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
      $      (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
             NCOL=1
           ELSE
             NCOL=2
           ENDIF
           DO 440 I=MMIN1,MMAX1
             IF(KFAC(1,I).EQ.0) GOTO 440
             IP=I
             IF(IP.EQ.0) IP=21
             IA=ABS(IP)
             DO 430 J=MMIN2,MMAX2
               IF(KFAC(2,J).EQ.0) GOTO 430
               JP=J
               IF(JP.EQ.0) JP=21
               JA=ABS(JP)
               IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
      $          (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
                 KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
                 IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
                   DO II=1,NCOL
                     NCHN=NCHN+1
                     ISIG(NCHN,1)=IP
                     ISIG(NCHN,2)=JP
                     ISIG(NCHN,3)=II
                     SIGH(NCHN)=FACT/NCOL
                   ENDDO
                 ENDIF
               ENDIF
  430        CONTINUE
  440      CONTINUE
         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(23000,5),P(23000,5),V(23000,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--use nuclear pdf?      
       COMMON/NPDF/MASS,NSET,EPS09,INITSTR
       INTEGER NSET
       DOUBLE PRECISION MASS
       LOGICAL EPS09
       CHARACTER*10 INITSTR
 
 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 setlhaparm('SILENT')
             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)
           IF(EPS09)THEN
            call setlhaparm(INITSTR)
            CALL STRUCTA(XX,QQ,MASS,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,
      &                                                                          GLU)
           ELSE
            CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
           ENDIF
           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...DECAY TABLE writeout by Nils-Erik Bomark (2010)
 
 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='10 Jun 2010')
 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).AND.IMSS21.NE.0) MLHEF=1
       IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) 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...Flag that we are skipping until <slha> tag found (if LHEF)
       ISKIP=0
       IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=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...If reading from LHEF file, skip until <slha> begin tag found
         IF (ISKIP.NE.0) THEN 
           DO 205 I1=1,10
             IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
  205      CONTINUE        
           IF (ISKIP.NE.0) GOTO 170
         ENDIF
 
 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
             ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24) 
      &        THEN
 C...Set block skip flag and read next line
               WRITE(MSTU(11),'(A,I9,A,F12.3)')
      &             ' * (PYSLHA:) Allowing DECAY table for KF =',
      &             KF, ' but this is NOT recommended.'
             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,8500) 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,8500) PMAS(PYCOMP(24),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,8500) 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',' '
 C       WRITE(LFN,7210) 1, RMSS(18), 'alpha'
         WRITE(LFN,7200) 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)
  
 C...DECAY TABLES writeout
 C...Write decay information by Nils-Erik Bomark 3/29/2010
       ELSEIF (MUPDA.EQ.4) THEN
         KF = KFORIG
         KC = PYCOMP(KF)
         IF (KC.NE.0) THEN
           WRITE(LFN,7000) ''
           WRITE(LFN,7000) '         PDG            Width'
           WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
           WRITE(LFN,7000) 
      &   '          BR         NDA      ID1        ID2       ID3'
           DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
             NDA = 0
             DO 570 J=1,5
               IF (KFDP(I,J).NE.0) NDA = NDA+1
  570        CONTINUE
             IF (NDA.EQ.2) 
      &         WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
             IF (NDA.EQ.3) 
      &         WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
             IF (NDA.EQ.4) 
      &         WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
             IF (NDA.EQ.5) 
      &         WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
      &           CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
      &             (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
  575        CONTINUE
         ENDIF
 C....End of DECAY TABLES writeout
 
       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.14: 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,1P,E16.8,0P,3x,'#',1x,A)
  7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
  7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
      &  '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
  7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
      &  '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
  7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
      &  '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
  7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
      &  '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
 
       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(23000,5),P(23000,5),V(23000,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)
       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/,/PYPARS/,/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(MSTP(47).EQ.0) THEN
         ISKIP=0
       ELSEIF(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(PYCOMP(KFDP(IDC,1)),1)**2/SH
           RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
           IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
           IF(I.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(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.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
 
 C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
 C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement 
 C *             from above, thanks to N.-E. Bomark.
                   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
               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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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-Q2O : 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   316  ATLAS MC08 : pT-ordered showers, CTEQ6L1             (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   327 Perugia 10: Alternative to Perugia 0, with more FSR   (May 2010)
 C                   off ISR, more BR breakup, more strangeness
 C   328 Perugia K : Alternative to Perugia 2010, with a       (May 2010)   
 C                   K-factor applied to MPI cross sections
 C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
 C   329 Pro-pTO   : Professor pT-ordered tune w. S0 CR model  (Feb 2009)
 C ---- Tunes introduced in 6.4.23:
 C   330 ATLAS MC09 : pT-ordered showers, LO* PDFs             (2009)
 C   331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
 C   334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI   (Oct 2010)
 C   335 Pro-pT*   : Professor Tune with LO*                   (Mar 2009)
 C   336 Pro-pT6   : Professor Tune with CTEQ6LL               (Mar 2009)
 C   339 Pro-pT**  : Professor Tune with LO**                  (Mar 2009)
 C   340 AMBT1   : First ATLAS tune including 7 TeV data       (May 2010)
 C   341 Z1      : First CMS tune including 7 TeV data         (Aug 2010)
 C   342 Z1-LEP  : CMS tune Z1, with improved LEP parameters   (Oct 2010)
 C   343 Z2        : Retune of Z1 by Field w CTEQ6L1 PDFs          (2010)
 C   344 Z2-LEP    : Retune of Z1 by Skands w CTEQ6L1 PDFs     (Feb 2011)
 C   350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
 C   351 P2011 radHi : Variation with alphaS(pT/2) 
 C   352 P2011 radLo : Variation with alphaS(2pT)
 C   353 P2011 mpiHi : Variation with more semi-hard MPI
 C   354 P2011 noCR  : Variation without color reconnections
 C   355 P2011 LO**  : Perugia 2011 using MSTW LO** PDFs       (Mar 2011)
 C   356 P2011 C6    : Perugia 2011 using CTEQ6L1 PDFs         (Mar 2011)
 C   357 P2011 T16   : Variation with PARP(90)=0.32 away from 7 TeV
 C   358 P2011 T32   : Variation with PARP(90)=0.16 awat from 7 TeV
 C   359 P2011 TeV   : Perugia 2011 optimized for Tevatron     (Mar 2011)
 C   360 S Global    : Schulz-Skands Global fit                (Mar 2011)
 C   361 S 7000      : Schulz-Skands at 7000 GeV               (Mar 2011)
 C   362 S 1960      : Schulz-Skands at 1960 GeV               (Mar 2011)
 C   363 S 1800      : Schulz-Skands at 1800 GeV               (Mar 2011)
 C   364 S 900       : Schulz-Skands at 900 GeV                (Mar 2011)
 C   365 S 630       : Schulz-Skands at 630 GeV                (Mar 2011)
 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-Q2O (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   ATLAS MC08 (316). CTEQ6L1 parton distributions
 C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
 C...* Warning: uses Peterson fragmentation function for heavy quarks
 C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
 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   Perugia-2010 (327). CTEQ5L parton distributions
 C...Key feature: Retune of Perugia 0 to attempt to better describe 
 C...strangeness yields at RHIC and at LEP. Also increased the amount 
 C...of FSR off ISR following the conclusions in arXiv:1001.4082. 
 C...Increased the amount of beam blowup, causing more baryon transport
 C...into the detector, to further explore this possibility. Using 
 C...a new color-reconnection model that relies on determining a thrust
 C...axis for the events and then computing reconnection probabilities for
 C...the individual string pieces based on the actual string densities
 C...per rapidity interval along that thrust direction.
 C
 C   Perugia-K (328). CTEQ5L parton distributions 
 C...Key feature: uses a ``K'' factor on the MPI cross sections
 C...This gives a larger rate of minijets and pushes the underlying-event 
 C...activity towards higher pT. To compensate for the increased activity 
 C...at higher pT, the infared regularization scale is larger for this tune.
 C
 C   Pro-pTO (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   ATLAS MC09 (330). LO* parton distributions
 C...Key feature: Good overall agreement with Tevatron and early LHC data.
 C...Similar to Perugia *.
 C
 C   ATLAS MC09c (331). LO* parton distributions
 C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
 C...Similar to Perugia *. Retuned CR model with respect to MC09.
 C
 C   Pro-pT* (335) LO* parton distributions
 C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
 C
 C   Pro-pT6 (336). CTEQ6L1 parton distributions
 C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
 C
 C   Pro-pT** (339). LO** parton distributions
 C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
 C
 C   AMBT1 (340). LO* parton distributions
 C...Key feature: First ATLAS tune including 7-TeV LHC data.
 C...Mainly retuned CR and mass distribution with respect to MC09c.
 C...Note: cannot be run standalone since it uses external PDFs.
 C
 C   CMSZ1 (341). CTEQ5L parton distributions
 C...Key feature: First CMS tune including 7-TeV LHC data.
 C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs, 
 C...has a lower pT0 at the Tevatron, which scales faster with energy. 
 C
 C   Z1-LEP (342). CTEQ5L parton distributions
 C...Key feature: CMS tune Z1 with improved LEP parameters, mostly 
 C...taken from the Professor/Perugia tunes, with a few minor updates.
 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 CHDOC
       PARAMETER (CHDOC='Mar 2011')
       CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
       CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
      &    CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), 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-Q2O'/
       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,316)/
      &    'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
      &    'NOCR-Pro','Old-Pro','ATLAS MC08'/
       DATA (CHNAMS(I),I=320,329)/
      &    'Perugia 0','Perugia HARD','Perugia SOFT',
      &    'Perugia 3','Perugia NOCR','Perugia LO*',
      &    'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
       DATA (CHNAMS(I),I=330,349)/
      &     'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
      &     'Pro-PT6',' ',' ','Pro-PT**',
      4     'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
      4     5*' '/
       DATA (CHNAMS(I),I=350,359)/
      &     'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
      &     'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
      &     'P2011 T16','P2011 T32','P2011 Tevatron'/
       DATA (CHNAMS(I),I=360,369)/
      &     'S Global','S 7000','S 1960','S 1800',
      &     'S 900','S 630', 4*' '/
       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=1,10)/
      &    2*' ','INT switch for choice of LambdaQCD',7*' '/
       DATA (CHMSTP(I),I=31,40)/
      &    2*' ','"K" switch for K-factor on/off & type',7*' '/
       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    'IFSR scheme for non-decay FSR',8*' ',
      8    'UE model',
      8    'UE hadron transverse mass distribution',5*' ',
      8    'BR composite scheme','BR color scheme',
      9    'BR primordial kT compensation',
      9    'BR primordial kT distribution',
      9    'BR energy partitioning scheme',2*' ',
      9    'FSI color (re-)connection model',5*' '/
       DATA (CHPARP(I),I=1,10)/
      &    'ME/UE LambdaQCD',9*' '/
       DATA (CHPARP(I),I=31,40)/
      &    ' ','"K" K-factor',8*' '/
       DATA (CHPARP(I),I=61,100)/
      6     'ISR LambdaQCD','ISR IR cutoff',' ',
      6     'ISR renormalization scale prefactor',
      6     2*' ','ISR Q2max factor',3*' ',
      7     'IFSR Q2max factor in non-s-channel procs',
      7     'IFSR LambdaQCD (outside resonance decays)',4*' ',
      7     'FSI color reco high-pT damping strength',
      7     'FSI color 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 color correlated fraction','UE total gg fraction',
      8     2*' ',
      8     'UE IR cutoff reference ecm',
      8     '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','HAD P(popcorn)',
      &     'HAD extra popcorn B(s)-M-B(s) supp',
      &     'HAD extra popcorn B-M(s)-B supp',
      &     3*' ',
      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(Meson)','HAD string parameter b',
      4     2*' ','HAD string a(Baryon)-a(Meson)',
      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 LambdaQCD (inside resonance decays)',
      &     'FSR IR cutoff',8*' '/
       DATA (CHMSTU(I),I=111,120)/
      1     ' ','INT n(flavors) for LambdaQCD',8*' '/
       DATA (CHPARU(I),I=111,120)/
      1     ' ','INT LambdaQCD',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) CHDOC
  
 C...Hardcode some defaults
 C...Get Lambda from PDF
       MSTP(3)  =  2      
 C...CTEQ5L1 PDFs
       MSTP(52) =  1
       MSTP(51) =  7
 C... No K-factor 
       MSTP(33) =  0
 
 C...3) Tune parameters
  
 C=======================================================================
 C...ATLAS MC08
 
       IF (ITUNE.EQ.316) 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...First set some explicit defaults from 6.4.20
 C...# Old defaults
         MSTJ(11) = 4
 C...# Old default flavour parameters
         PARJ(1)  =   0.1
         PARJ(2)  =   0.3  
         PARJ(3)  =   0.40 
         PARJ(4)  =   0.05 
         PARJ(11) =   0.5  
         PARJ(12) =   0.6 
         PARJ(21) = 0.36
         PARJ(41) = 0.30
         PARJ(42) = 0.58
         PARJ(46) = 1.0
         PARJ(82) = 1.0
 
 C...PDFs: CTEQ6L1 for 326
         MSTP(52)=2
         MSTP(51)=10042
 
 C...UE and ISR switches
         MSTP(81)=21
         MSTP(82)=4
         MSTP(70)=0
         MSTP(72)=1
 
 C...CR:
         MSTP(95)=2
         PARP(78)=0.3
         PARP(77)=0.0
         PARP(80)=0.1
 
 C...Primordial kT
         PARP(91)=2.0D0
         PARP(93)=5.0D0
 
 C...MPI:
         PARP(82)=2.1
         PARP(83)=0.8
         PARP(84)=0.7
         PARP(89)=1800.0
         PARP(90)=0.16
 
 C...FSR inside resonance decays
         PARJ(81)=0.29
 
 C...Fragmentation (warning: uses Peterson)
         MSTJ(11)=3   
         PARJ(54)=-0.07
         PARJ(55)=-0.006
         MSTJ(22)=2
         
         IF (M13.GE.1) THEN
           CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
           WRITE(M11,5030) CH60
           CH60='Physics model: '//
      &         '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
           
 C...Output
           WRITE(M11,5030) ' '
           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
           IF (MSTP(70).EQ.0) THEN
             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
           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) 33, MSTP(33), CHMSTP(33)
           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,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
 
         ENDIF
  
 C=======================================================================
 C...ATLAS MC09, MC09c, AMBT1
 C...CMS Z1 (R. Field), Z1-LEP
 
       ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
      &       ITUNE.GE.341.AND.ITUNE.LE.344) 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...First set some explicit defaults from 6.4.20
         IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
 C...  # Old defaults
           MSTJ(11) = 4
 C...# Old default flavour parameters
           PARJ(1)  =   0.1
           PARJ(2)  =   0.3  
           PARJ(3)  =   0.40 
           PARJ(4)  =   0.05 
           PARJ(11) =   0.5  
           PARJ(12) =   0.6 
           PARJ(21) = 0.36
           PARJ(41) = 0.30
           PARJ(42) = 0.58
           PARJ(46) = 1.0
           PARJ(82) = 1.0
         ELSE
 C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
           PARJ( 1) = 0.08D0
           PARJ( 2) = 0.21D0
           PARJ(3)  = 0.94
           PARJ( 4) = 0.04D0
           PARJ(11) = 0.35D0
           PARJ(12) = 0.35D0
           PARJ(13) = 0.54
           PARJ(25) = 0.63
           PARJ(26) = 0.12
 C...# Switch on Bowler:
           MSTJ(11) = 5
 C...# Fragmentation
           PARJ(21) = 0.34D0
           PARJ(41) = 0.35D0
           PARJ(42) = 0.80D0
           PARJ(47) = 1.0
           PARJ(81) = 0.26D0
           PARJ(82) = 1.0D0
         ENDIF
 
 C...PDFs: MRST LO* 
         MSTP(52)=2
         MSTP(51)=20650
         IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
 C...Z1 uses CTEQ5L
           MSTP(52)=1
           MSTP(51)=7
         ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
 C...Z2 uses CTEQ6L
           MSTP(52)=2
           MSTP(51)=10042
         ENDIF
 
 C...UE and ISR switches
         MSTP(81)=21
         MSTP(82)=4
         MSTP(70)=0
         MSTP(72)=1
 
 C...CR:
         MSTP(95)=6
         PARP(78)=0.3
         PARP(77)=0.0
         PARP(80)=0.1
         IF (ITUNE.EQ.331) THEN
           PARP(78)=0.224          
         ELSEIF (ITUNE.EQ.340) THEN
 C...AMBT1
           PARP(77)=1.016D0
           PARP(78)=0.538D0
         ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
 C...Z1 and Z2 use the AMBT1 CR values
           PARP(77)=1.016D0
           PARP(78)=0.538D0
         ENDIF
 
 C...MPI:
         PARP(82)=2.3
         PARP(83)=0.8
         PARP(84)=0.7
         PARP(89)=1800.0
         PARP(90)=0.25
         IF (ITUNE.EQ.331) THEN
           PARP(82)=2.315
           PARP(90)=0.2487
         ELSEIF (ITUNE.EQ.340) THEN
           PARP(82)=2.292D0
           PARP(83)=0.356D0
           PARP(84)=0.651
           PARP(90)=0.25D0
         ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
           PARP(82)=1.932D0
           PARP(83)=0.356D0
           PARP(84)=0.651
           PARP(90)=0.275D0
         ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
           PARP(82)=1.832D0
           PARP(83)=0.356D0
           PARP(84)=0.651
           PARP(90)=0.275D0
         ENDIF
         
 C...Primordial kT
         PARP(91)=2.0D0
         PARP(93)=5D0
         IF (ITUNE.GE.340) THEN
           PARP(93)=10D0
         ENDIF
 
 C...ISR
         IF (ITUNE.GE.340) THEN
           PARP(62)=1.025
         ENDIF
 
 C...FSR inside resonance decays
         PARJ(81)=0.29
 
 C...Fragmentation (org 6.4 defs hardcoded)
         MSTJ(11)=4
         PARJ(41)=0.3
         PARJ(42)=0.58
         MSTJ(22)=2
 C...AMBT1 mentions 46 explicitly, but Z1 doesn't ...         
         PARJ(46)=0.75
         IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
 C...Reset PARJ(46) to org def value for Z1 and Z2
           PARJ(46)=1.0
         ENDIF
 
         IF (M13.GE.1) THEN
           IF (ITUNE.LT.340) THEN
             CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
           ELSEIF (ITUNE.EQ.340) THEN
             CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
           ELSEIF (ITUNE.EQ.341) THEN
             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
             WRITE(M11,5030) CH60
             CH60='Z1 variation tuned by R. D. Field (CMS)'
           ELSEIF (ITUNE.EQ.342) THEN
             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
             WRITE(M11,5030) CH60
             CH60='Z1 variation retuned by R. D. Field (CMS)'
             WRITE(M11,5030) CH60
             CH60='Z1-LEP variation retuned by Professor / P. Skands'
           ELSEIF (ITUNE.EQ.343) THEN
             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
             WRITE(M11,5030) CH60
             CH60='Z2 variation retuned by R. D. Field (CMS)'
           ELSEIF (ITUNE.EQ.344) THEN
             CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
             WRITE(M11,5030) CH60
             CH60='Z2 variation retuned by R. D. Field (CMS)'
             WRITE(M11,5030) CH60
             CH60='Z2-LEP variation retuned by Professor / P. Skands'
           ENDIF
           WRITE(M11,5030) CH60
           CH60='Physics Model: '//
      &         '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
 
 C...Output
           WRITE(M11,5030) ' '
           WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
           WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
           IF (MSTP(70).EQ.0) THEN
             WRITE(M11,5050) 62, PARP(62), CHPARP(62)
           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) 33, MSTP(33), CHMSTP(33)
           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,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
 
         ENDIF
 
 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, 3, LO*, 6, 2010, K
 C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
 C...Perugia 2011 (incl variations)
 C...Schulz-Skands tunes
       ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
      &    .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
      &    .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
      &    .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
      &    .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) 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.339.AND.ITUNE.NE.324.AND.
      &         ITUNE.NE.334.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.')
         ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
      &         (MSTP(181).LE.5.OR.
      &         (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
      &        THEN
           CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
      &        ' with tune.')
         ENDIF
  
 C...Use 327 as base tune for 350-359 (Perugia 2011)
         ITUNSV = ITUNE
         IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
 C...Use 320 as base tune for 360+ (Schulz-Skands)
         IF (ITUNE.GE.360) ITUNE = 320
 
 C...HAD: 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 defaults
           MSTJ(11) = 4
 C...# Old default flavour parameters
           PARJ(1)  =   0.1
           PARJ(2)  =   0.3  
           PARJ(3)  =   0.40 
           PARJ(4)  =   0.05 
           PARJ(11) =   0.5  
           PARJ(12) =   0.6 
           PARJ(21) = 0.36
           PARJ(41) = 0.30
           PARJ(42) = 0.58
           PARJ(46) = 1.0
           PARJ(82) = 1.0
           
         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
 
 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...HAD: P-2010 and P-K use different strangeness parameters 
 C...     indicated by LEP and RHIC yields.
 C...(only 5% different from Professor values, so should be within acceptable
 C...theoretical uncertainty range)
 C...(No attempt made to retune other flavor parameters post facto)
           IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
             PARJ( 1) = 0.08D0
             PARJ( 2) = 0.21D0
             PARJ( 4) = 0.04D0
             PARJ(11) = 0.35D0
             PARJ(12) = 0.35D0
             PARJ(21) = 0.36D0
             PARJ(41) = 0.35D0
             PARJ(42) = 0.90D0
             PARJ(81) = 0.26D0
             PARJ(82) = 1.0D0
           ENDIF 
         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.OR.ITUNE.EQ.335) THEN
 C...MRST LO* for 325 and 335
           MSTP(52)=2
           MSTP(51)=20650
         ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
 C...CTEQ6L1 for 326 and 336
           MSTP(52)=2
           MSTP(51)=10042
         ELSEIF (ITUNE.EQ.339) THEN
 C...MRST LO** for 339
           MSTP(52)=2
           MSTP(51)=20651
         ENDIF
  
 C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
         MSTP(3)=2
         IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
           MSTP(3)   = 1
 C...Hardcode CTEQ5L values for ME and ISR
           MSTU(112) = 4
           PARU(112) = 0.192D0
           PARP(61)  = 0.192D0
           PARP( 1)  = 0.192D0
 C...but use LEP value also for non-res FSR
           PARP(72)  = 0.260D0
         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.334
      &       .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) 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.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
      &         ITUNE.EQ.339) THEN
 C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
           MSTP(64)=2
           PARP(64)=1.3D0
           IF (ITUNE.EQ.335) PARP(64)=0.92D0
           IF (ITUNE.EQ.336) PARP(64)=0.89D0
           IF (ITUNE.EQ.339) PARP(64)=0.97D0
         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.328).OR.ITUNE.EQ.334) THEN
           PARP(67)=1D0
           IF (ITUNE.EQ.321) PARP(67)=4D0
           IF (ITUNE.EQ.322) PARP(67)=0.25D0
         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
         ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
 C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
           MSTP(70)=2
           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.328).OR.ITUNE.EQ.334) THEN 
           PARP(71)=2D0
           IF (ITUNE.EQ.321) PARP(71)=4D0
           IF (ITUNE.EQ.322) PARP(71)=1D0
         ENDIF
         IF (ITUNE.EQ.329) PARP(71)=2D0
         IF (ITUNE.EQ.335) PARP(71)=1.29D0
         IF (ITUNE.EQ.336) PARP(71)=1.72D0
         IF (ITUNE.EQ.339) PARP(71)=1.20D0
 
 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...K-factor : only 328 uses a K-factor on the UE cross sections
         MSTP(33)=0
         IF (ITUNE.EQ.328) THEN
           MSTP(33)=10
           PARP(32)=1.5
         ENDIF
 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.328).OR.ITUNE.EQ.334) 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.327) PARP(83)=1.5D0
           IF (ITUNE.EQ.328) PARP(83)=1.5D0
 C...NOCR variants have smoother mass profiles
           IF (ITUNE.EQ.324) PARP(83)=1.8D0
           IF (ITUNE.EQ.334) PARP(83)=1.8D0
         ENDIF
 C...Professor-pT0 also has very smooth distribution
         IF (ITUNE.EQ.329) PARP(83)=1.8
         IF (ITUNE.EQ.335) PARP(83)=1.68
         IF (ITUNE.EQ.336) PARP(83)=1.72
         IF (ITUNE.EQ.339) PARP(83)=1.67
 
 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.328).OR.ITUNE.EQ.334) 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
           IF (ITUNE.EQ.327) PARP(82)=2.05D0
           IF (ITUNE.EQ.328) PARP(82)=2.45D0
           IF (ITUNE.EQ.334) PARP(82)=2.15D0
         ENDIF
 C...Professor-pT0 maintains low pT0 vaue
         IF (ITUNE.EQ.329) PARP(82)=1.85D0
         IF (ITUNE.EQ.335) PARP(82)=2.10D0
         IF (ITUNE.EQ.336) PARP(82)=1.83D0
         IF (ITUNE.EQ.339) PARP(82)=2.28D0
 
 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.328).OR.ITUNE.EQ.334) 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
         IF (ITUNE.EQ.335) PARP(90)=0.20D0
         IF (ITUNE.EQ.336) PARP(90)=0.20D0
         IF (ITUNE.EQ.339) PARP(90)=0.21D0
 
 C...BR: MPI initiator color connections rap-ordered by default
 C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
         MSTP(89)=1
         IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
         IF (ITUNE.EQ.322) MSTP(89)=0
         IF (ITUNE.EQ.327) MSTP(89)=0
         IF (ITUNE.EQ.328) 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.328) 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
           IF (ITUNE.EQ.327) PARP(80)=0.1
           IF (ITUNE.EQ.328) PARP(80)=0.1
         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
         IF (ITUNE.EQ.335) PARP(79)=1.11
         IF (ITUNE.EQ.336) PARP(79)=1.10
         IF (ITUNE.EQ.339) PARP(79)=3.69
 
 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
         IF (ITUNE.EQ.335) THEN
           PARP(91)=2.15
           PARP(93)=6.79
         ELSEIF (ITUNE.EQ.336) THEN
           PARP(91)=1.85
           PARP(93)=6.86
         ELSEIF (ITUNE.EQ.339) THEN
           PARP(91)=2.11
           PARP(93)=5.08
         ENDIF
 
 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.OR.
      &       ITUNE.EQ.334) MSTP(95)=0
 C..."Old" and "Old"-Pro: use old CR
         IF (ITUNEB.EQ.305) MSTP(95)=1
 C...Perugia 2010 and K use Paquis model
         IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8
  
 C...FSI: CR strength and high-pT dampening, default is S0
         PARP(77)=0D0
         IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
           PARP(78)=0.2D0
           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
           IF (ITUNE.EQ.335) PARP(78)=0.14D0
           IF (ITUNE.EQ.336) PARP(78)=0.17D0
           IF (ITUNE.EQ.339) PARP(78)=0.13D0
         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.OR.ITUNE.EQ.334) THEN
 C...NOCR has no CR
             PARP(78)=0D0
             PARP(77)=0D0
           ELSEIF (ITUNE.EQ.327) THEN
 C...2010
             PARP(78)=0.035D0
             PARP(77)=1D0
           ELSEIF (ITUNE.EQ.328) THEN
 C...K
             PARP(78)=0.033D0
             PARP(77)=1D0
           ENDIF
         ENDIF
  
 C================
 C...Perugia 2011 tunes 
 C...(written as modifications on top of Perugia 2010)
 C================
         IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN
           ITUNE = ITUNSV
 C...  Scale setting for matching applications.
 C...  Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
 C...  (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
           MSTP(64)=2
           MSTU(112)=5
 C...  This sets the Lambda scale for ISR, IFSR, and FSR
           PARP(61)=0.26D0
           PARP(72)=0.26D0
           PARJ(81)=0.26D0
 C...  This sets the Lambda scale for QCD hard interactions (important for the 
 C...  UE dijet cross sections. Here we still use an MSbar value, rather than 
 C...  a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
 C...  value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
           PARP(1)=0.16D0
           PARU(112)=0.16D0
 C...  For matching applications, PARP(71) and PARP(67) = 1
           PARP(67) = 1D0
           PARP(71) = 1D0
 C...  Primordial kT: only use 1 GeV
           MSTP(91)=1
           PARP(91)=1D0
 C...  ADDITIONAL LESSONS WRT PERUGIA 2010
 C...  ALICE taught us: need less baryon transport than SOFT
           MSTP(89)=0
           PARP(80)=0.015
 C...  Small adjustments at LEP (slightly softer frag functions, esp for baryons)
           PARJ(21)=0.33
           PARJ(41)=0.35
           PARJ(42)=0.8
           PARJ(45)=0.55
 C...  Increase Lambda/K ratio and other strange baryon yields 
           PARJ(1)=0.087D0
           PARJ(3)=0.95D0
           PARJ(4)=0.043D0
           PARJ(6)=1.0D0
           PARJ(7)=1.0D0
 C...  Also reduce total strangeness yield a bit, with higher K*/K
           PARJ(2)=0.19D0
           PARJ(12)=0.40D0
 C...  Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
           MSTP(70)=0
           MSTP(72)=2
           PARP(62)=1.5D0
 C...  Holger taught us a smoother proton is preferred at high energies
 C...  Just use a simple Gaussian 
           MSTP(82)=3
 C...  Scaling of pt0 cutoff
           PARP(90)=0.265
 C...  Now retune pT0 to give right UE activity.
 C...  Low CR strength indicated by LHC tunes 
 C...  (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
           PARP(78)=0.036D0
 C...  Choose 7 TeV as new reference scale
           PARP(89)=7000.0D0
           PARP(82)=2.93D0          
 C================
 C...  P2011 Variations
 C================
           IF (ITUNE.EQ.351) THEN
 C...  radHi: high Lambda scale for ISR, IFSR, and FSR
 C...  ( ca 10% more particles at LEP after retune )
             PARP(61)=0.52D0
             PARP(72)=0.52D0
             PARJ(81)=0.52D0
 C...  Retune cutoff scales to compensate partially
 C...  (though higher cutoff causes faster multiplicity drop at low energies)
             PARP(62)=1.75D0
             PARJ(82)=1.75D0
             PARP(82)=3.00D0
 C...  Needs faster cutoff scaling than nominal variant for same <Nch> scaling
 C...  (since more radiation otherwise generates faster mult growth)
             PARP(90)=0.28  
           ELSEIF (ITUNE.EQ.352) THEN
 C...  radLo: low Lambda scale for ISR, IFSR, and FSR
 C...  ( ca 10% less particles at LEP after retune )
             PARP(61)=0.13D0
             PARP(72)=0.13D0
             PARJ(81)=0.13D0
 C...  Retune cutoff scales to compensate partially
             PARP(62)=1.00D0
             PARJ(82)=0.75D0
             PARP(82)=2.95D0 
 C...  Needs slower cutoff scaling than nominal variant for same <Nch> scaling
 C...  (since less radiation otherwise generates slower mult growth)
             PARP(90)=0.24
           ELSEIF (ITUNE.EQ.353) THEN
 C...  mpiHi: high Lambda scale for MPI
             PARP(1)=0.26D0
             PARU(112)=0.26D0
             PARP(82)=3.35D0
             PARP(90)=0.26D0
           ELSEIF (ITUNE.EQ.354) THEN
             MSTP(95)=0
             PARP(82)=3.05D0
           ELSEIF (ITUNE.EQ.355) THEN
 C...  LO**
             MSTP(52)=2
             MSTP(51)=20651
             PARP(62)=1.5D0
 C...  Compensate for higher <pT> with less CR
             PARP(78)=0.034
             PARP(82)=3.40D0 
 C...  Need slower energy scaling than CTEQ5L
             PARP(90)=0.23D0 
           ELSEIF (ITUNE.EQ.356) THEN
 C...  CTEQ6L1
             MSTP(52)=2
             MSTP(51)=10042
             PARP(82)=2.65D0
 C...  Need slower cutoff scaling than CTEQ5L
             PARP(90)=0.22D0 
           ELSEIF (ITUNE.EQ.357) THEN
 C...  T16
             PARP(90)=0.16
           ELSEIF (ITUNE.EQ.358) THEN
 C...  T32
             PARP(90)=0.32
           ELSEIF (ITUNE.EQ.359) THEN
 C...  Tevatron
             PARP(89)=1800D0
             PARP(90)=0.28 
             PARP(82)=2.10 
             PARP(78)=0.05 
           ENDIF
           
 C================
 C...Schulz-Skands 2011 tunes 
 C...(written as modifications on top of Perugia 0)
 C================
         ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
           ITUNE = ITUNSV
 
           IF (ITUNE.EQ.360) THEN
             PARP(78)=0.40D0
             PARP(82)=2.19D0
             PARP(83)=1.45D0
             PARP(89)=1800.0D0
             PARP(90)=0.27D0
           ELSEIF (ITUNE.EQ.361) THEN
             PARP(78)=0.20D0
             PARP(82)=2.75D0
             PARP(83)=1.73D0
             PARP(89)=7000.0D0
           ELSEIF (ITUNE.EQ.362) THEN
             PARP(78)=0.31D0
             PARP(82)=1.97D0
             PARP(83)=1.98D0
             PARP(89)=1960.0D0
           ELSEIF (ITUNE.EQ.363) THEN
             PARP(78)=0.35D0
             PARP(82)=1.91D0
             PARP(83)=2.02D0
             PARP(89)=1800.0D0
           ELSEIF (ITUNE.EQ.364) THEN
             PARP(78)=0.33D0
             PARP(82)=1.69D0
             PARP(83)=1.92D0
             PARP(89)=900.0D0
           ELSEIF (ITUNE.EQ.365) THEN
             PARP(78)=0.47D0
             PARP(82)=1.61D0
             PARP(83)=1.50D0
             PARP(89)=630.0D0
           ENDIF
 
         ENDIF
         
 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,'//
      &             ' hep-ph/0907.2973'
               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 by Professor,'//
      &             ' hep-ph/0907.2973'
               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,'//
      &             ' hep-ph/0907.2973'
               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,'//
      &             ' hep-ph/0907.2973'
               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,'//
      &             ' hep-ph/0907.2973'
               WRITE(M11,5030) CH60
             ENDIF
           ENDIF
  
 C...Perugia Tunes (320-328 and 334)
         ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
           IF (M13.GE.1) THEN
             CH60='Tuned by P. Skands, hep-ph/1005.3457'
             WRITE(M11,5030) CH60
             CH60='Physics Model: '//
      &           'T. Sjostrand & P. Skands, hep-ph/0408302'
             WRITE(M11,5030) CH60
             IF (ITUNE.LE.326) THEN
               CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
               WRITE(M11,5030) CH60
               CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
               WRITE(M11,5030) CH60
             ENDIF
             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-pTO (329)
         ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
      &         ITUNE.EQ.339) THEN
           IF (M13.GE.1) THEN
             CH60='Tuned by Professor, hep-ph/0907.2973'
             WRITE(M11,5030) CH60 
             CH60='Physics Model: '//
      &           '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
           ENDIF
  
 C...Perugia 2011 Tunes (350-359)
         ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
           IF (M13.GE.1) THEN
             CH60='Tuned by P. Skands, hep-ph/1005.3457'
             WRITE(M11,5030) CH60
             CH60='Physics Model: '//
      &           '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
             IF (ITUNE.EQ.355) THEN
               CH70='NB! This tune requires MRST LO** pdfs to be '//
      &            'externally linked'
               WRITE(M11,5035) CH70
             ELSEIF (ITUNE.EQ.356) THEN
               CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
      &            'externally linked'
               WRITE(M11,5035) CH70
             ENDIF
           ENDIF
 
 C...Schulz-Skands Tunes (360-365)
         ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
           IF (M13.GE.1) THEN
             CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
             WRITE(M11,5030) CH60
             CH60='Based on Perugia 0, hep-ph/1005.3457'
             WRITE(M11,5030) CH60
             CH60='Physics Model: '//
      &           '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
           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(33).GE.10) THEN
             WRITE(M11,5050) 32, PARP(32), CHPARP(32)
           ENDIF
           WRITE(M11,5040)  3, MSTP( 3), CHMSTP( 3)
           IF (MSTP(3).EQ.1) THEN
             WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
             WRITE(M11,6110) 112, PARU(112), CHPARU(112)
             WRITE(M11,5050)   1, PARP(1)  , CHPARP(  1)
           ENDIF
           WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
           IF (MSTP(3).EQ.1) 
      &         WRITE(M11,5050)  72, PARP(72) , CHPARP( 72)
           IF (MSTP(3).EQ.1) THEN
             WRITE(M11,5050)  61, PARP(61) , CHPARP( 61)
           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,5040) 68, MSTP(68), CHMSTP(68)
           CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
           WRITE(M11,5030) CH60
           WRITE(M11,5050) 67, PARP(67), CHPARP(67)
           WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
           WRITE(M11,5050) 71, PARP(71), CHPARP(71)
           WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
           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,5060) 82, PARJ(82), CHPARJ(82)
           WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
           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)
           IF (MSTP(82).EQ.5) THEN
             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
           ELSEIF (MSTP(82).EQ.4) THEN
             WRITE(M11,5050) 83, PARP(83), CHPARP(83)
             WRITE(M11,5050) 84, PARP(84), CHPARP(84)
           ENDIF
           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
 
         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,5040)  3, MSTP( 3), CHMSTP( 3)
           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) 33, MSTP(33), CHMSTP(33)
           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)
 
         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-Q2O (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, hep-ph/0907.2973'
             WRITE(M11,5030) CH60
           ENDIF
         ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
           WRITE(M11,5010) ITUNE, CHNAME
           CH60='Tuned by Professor, hep-ph/0907.2973'
           WRITE(M11,5030) CH60
           CH60='Physics Model: '//
      &         'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
           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.LT.110) THEN
 C...# Old defaults
           MSTJ(11) = 4
           PARJ(1)  =   0.1
           PARJ(2)  =   0.3  
           PARJ(3)  =   0.40 
           PARJ(4)  =   0.05 
           PARJ(11) =   0.5  
           PARJ(12) =   0.6 
           PARJ(21) = 0.36
           PARJ(41) = 0.30
           PARJ(42) = 0.58
           PARJ(46) = 1.0
           PARJ(81) = 0.29
           PARJ(82) = 1.0
         ELSE
 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-Q2O Tune
         ELSEIF(ITUNE.EQ.129) THEN
           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,5040)  3, MSTP( 3), CHMSTP( 3)
           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) 33, MSTP(33), CHMSTP(33)
           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)
 
         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, hep-ph/0907.2973'
             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.LT.110) THEN
 C...# Old defaults
           MSTJ(11) = 4
 C...# Old default flavour parameters
           PARJ(21) = 0.36
           PARJ(41) = 0.30
           PARJ(42) = 0.58
           PARJ(46) = 1.0
           PARJ(82) = 1.0
         ELSE
 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,5040)  3, MSTP( 3), CHMSTP( 3)
           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) 33, MSTP(33), CHMSTP(33)
           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)
 
         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,5040)  3, MSTP( 3), CHMSTP( 3)
           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) 33, MSTP(33), CHMSTP(33)
           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)
 
         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, hep-ph/0907.2973'
             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)
         PARJ(54)=-0.05
         PARJ(55)=-0.005
  
 C...Use Professor's LEP pars if ITUNE == 211, 221, 226
         IF (ITUNE.LT.210) THEN
 C...# Old defaults
           MSTJ(11) = 4
 C...# Old default flavour parameters
           PARJ(21) = 0.36
           PARJ(41) = 0.30
           PARJ(42) = 0.58
           PARJ(46) = 1.0
           PARJ(82) = 1.0
         ELSE
 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,5040)  3, MSTP( 3), CHMSTP( 3)
           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) 33, MSTP(33), CHMSTP(33)
           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)
 
         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
  
 C...Output of LEP parameters, common to all models
       IF (M13.GE.1) THEN
         WRITE(M11,5080) 
         WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
         IF (MSTJ(11).EQ.3) THEN
           CH60='Warning: using Peterson fragmentation function'
           WRITE(M11,5030) CH60 
         ENDIF
         
         WRITE(M11,5060)  1, PARJ( 1), CHPARJ( 1)
         WRITE(M11,5060)  2, PARJ( 2), CHPARJ( 2)
         WRITE(M11,5060)  3, PARJ( 3), CHPARJ( 3)
         WRITE(M11,5060)  4, PARJ( 4), CHPARJ( 4)
         WRITE(M11,5060)  5, PARJ( 5), CHPARJ( 5)
         WRITE(M11,5060)  6, PARJ( 6), CHPARJ( 6)
         WRITE(M11,5060)  7, PARJ( 7), CHPARJ( 7)
         
         WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
         WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
         WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
         
         WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
         
         WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
         WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
         
         WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
         WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
         WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
         
         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
         
  100  IF (MSTU(13).GE.1) WRITE(M11,6000)
  
  9999 RETURN
  
  5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
      &    'Presets for underlying-event (and min-bias)',21x,'*'/' *',
      &    12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',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,'*')
  5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
  6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
  6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
 C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
 C 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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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,'(I6)') 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,'(I6)') 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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2-
      &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2
       DOTP(L,J)=P(L,4)*P(J,4)-P(L,1)*P(J,1)-P(L,2)*P(J,2)-P(L,3)*P(J,3)
  
 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=PYK(I,12)
         KCHA=PYK(I,6)
  
 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) THEN
             IF(K(I1M,2).EQ.K(I1,2)) THEN
               I1M=K(I1M,3)
               GOTO 260
             ENDIF
           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) THEN
               IF(K(I2M,2).EQ.K(I2,2)) THEN
                 I2M=K(I2M,3)
                 GOTO 270
               ENDIF
             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...Skip any particles that are "turned off"
           IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380
 
 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
             KC = PYCOMP(K(I,2))
             IF(K(I,2).EQ.21) THEN
               MOCT=1
             ELSEIF(KCHG(KC,2).EQ.2) THEN
               MOCT=2
             ENDIF
 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 520
  
 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
       KC = PYCOMP(K(I,2))
       IF(K(I,2).EQ.21) THEN
         MOCT=1
       ELSEIF(KCHG(KC,2).EQ.2) THEN
         MOCT=2
       ENDIF
 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
 C...  A) radiator-recoiler mother pair for this branching
         IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
           IPOS(IEVOL)=INEW
 C...  A2) QCD branching and color side matches, radiated parton follows recoiler
           IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
           IREC(IEVOL)=IRNEW
           IFLG(IEVOL)=0
         ELSEIF(IPOS(IEVOL).EQ.I) THEN
 C...  B) other dipoles with I as radiator simply get INEW as new radiator
           IPOS(IEVOL)=INEW
           IFLG(IEVOL)=0
         ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
 C...  C) the "mirror image" of the parent dipole
           IPOS(IEVOL)=IRNEW
           IREC(IEVOL)=INEW
 C...  C2) QCD branching and color side matches, radiated parton follows recoiler
           IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0)
      &         IREC(IEVOL)=IGNEW
           IFLG(IEVOL)=0
         ELSEIF(IPOS(IEVOL).EQ.IR) THEN
 C...  D) other dipoles with IR as radiator simply get IRNEW as new radiator
           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)
 C...g->qqbar: create new photon radiators.
       ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN
         NEVOL=NEVOL+1
         IPOS(NEVOL)=INEW
         IREC(NEVOL)=IGNEW
         IFLG(NEVOL)=0
         ISCOL(NEVOL)=0
         ISCHG(NEVOL)=PYK(INEW,6)
         PTSCA(NEVOL)=SQRT(PT2)
         NEVOL=NEVOL+1
         IPOS(NEVOL)=IGNEW
         IREC(NEVOL)=INEW
         IFLG(NEVOL)=0
         ISCOL(NEVOL)=0
         ISCHG(NEVOL)=PYK(IGNEW,6)
         PTSCA(NEVOL)=SQRT(PT2)
         CALL PYLIST(4)
         print*, 'created new QED dipole ',INEW,'<->',IGNEW
       ENDIF
  
 C...Check color and charge connections,
 C...Rewire if better partners can be found (screening, etc)
       DO 500 IEVOL=1,NEVOL
         KCOL  = ISCOL(IEVOL)
         KCHA  = ISCHG(IEVOL)
         IRTMP = IREC(IEVOL)
         ITMP  = IPOS(IEVOL)
 C...Do not modify QED dipoles
         IF (KCHA.NE.0) THEN
           GOTO 500
 C...Also skip dipole ends that are switched off
         ELSEIF (IFLG(IEVOL).LE.-1) THEN
           GOTO 500
         ELSEIF (KCOL.NE.0) THEN
 C...QCD dipoles. Check if current recoiler has appropriate color charge
           KCOLR = PYK(IRTMP,12)
           IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500
 C...If not, look for closest recoiler with appropriate color charge
           RM2MIN = PSUM(5)**2
           JMX    = 0
           ISGOOD = 0
           DO 490 JEVOL=1,NEVOL
 C...Skip self
             IF (JEVOL.EQ.IEVOL) GOTO 490
             JTMP = IPOS(JEVOL)
             IF (JTMP.EQ.ITMP) GOTO 490
             JCOL = ISCOL(JEVOL)
 C...Skip dipole ends that are switched off
             IF (IFLG(JEVOL).LE.-1) GOTO 490
 C...Skip QED dipole ends
             IF (ISCHG(JEVOL).NE.0) GOTO 490
 C...  Skip wrong-color if at least one correct-color partner already found
             IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490
 C...Accept if smallest m2 so far, or if first with correct color
             RM2 = DOTP(ITMP,JTMP)
             ISGNOW = 0
             IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1
             IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN
               ISGOOD = ISGNOW
               RM2MIN = RM2
               JMX    = JEVOL
             ENDIF
   490     CONTINUE
 C...Update recoiler and reset dipole if new best partner found
           IF (JMX.NE.0) THEN
             IREC(IEVOL) = IPOS(JMX)             
             IFLG(IEVOL) = 0
           ENDIF
         ENDIF
   500 CONTINUE
  
 C...TMP! print out list of dipoles
 C      DO 580 IEVOL=1,NEVOL
 C        KCHA  = ISCHG(IEVOL)
 C        IF (KCHA.NE.0) THEN
 C          print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
 C        ELSE
 C          print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
 C        ENDIF
 C 580  CONTINUE
  
 C...Update matrix elements parton list and add new for g/gamma->qqbar.
       DO 510 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
   510 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.
   520 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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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=19)
 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 201x',
      &'                                ',
      &'Now is xx xxx 201x at xx:xx:xx  ',
      &'                                ',
      &'Disclaimer: this program comes  ',
      &'without any guarantees. Beware  ',
      &'of errors and use common sense  ',
      &'when interpreting results.      ',
      &'                                ',
      &'Copyright T. Sjostrand (2011)   '/
       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; CERN/PH-TH, CH',
      &'-1211 Geneva, Switzerland           ',
      &'  phone: + 41 - 22 - 767 24 47; e-ma',
      &'il: peter.skands@cern.ch            '/
  
 C...Check that PYDATA linked (check we are in the year 20xx)
       IF(MSTP(183)/100.NE.20) 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
 
 
       WRITE(MSTU(11),'(A79)')
      &'+++++++++++++++++++++++++++++++++++++++++++++++++'//
      &'+++++++++++++++++++++++++++++' 
       WRITE(MSTU(11),'(A79)')
      &'++  This is a modified version of PYTHIA that may'//
      & ' only be used with JEWEL.  ++' 
       WRITE(MSTU(11),'(A79)')
      &'+++++++++++++++++++++++++++++++++++++++++++++++++'//
      &'+++++++++++++++++++++++++++++' 
  
 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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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
 
  
       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--event weight exponent
         COMMON/WEXPO/WEIGHTEX
         DOUBLE PRECISION WEIGHTEX
  
 C...Read out p_T^2
       PT2=VINT(48)
       WTXS=PT2**(WEIGHTEX/2.d0)
       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(23000,5),P(23000,5),V(23000,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