d6/dcf/pythia6425mod_8f_source.html

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